haskell-tools-daemon 0.4.1.1 → 0.4.1.3

raw patch · 9 files changed

+277/−104 lines, 9 filesdep +processdep ~directoryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: process

Dependency ranges changed: directory

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/Refactor/Daemon.hs +53/−40
• Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs +45/−0
• Language/Haskell/Tools/Refactor/Daemon/State.hs +4/−2
• examples/Project/empty/A.hs +1/−0
• examples/Project/load-error/A.hs +3/−0
• examples/Project/source-error/A.hs +4/−0
• exe/Main.hs +0/−2
• haskell-tools-daemon.cabal +9/−3
• test/Main.hs +158/−57

@@ -7,56 +7,45 @@            #-}
 module Language.Haskell.Tools.Refactor.Daemon where
 
+import Control.Applicative ((<|>))
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad
+import Control.Monad.State
 import Data.Aeson hiding ((.=))
 import Data.ByteString.Lazy.Char8 (ByteString)
 import Data.ByteString.Lazy.Char8 (unpack)
 import qualified Data.ByteString.Lazy.Char8 as BS
+import Data.IORef
+import Data.List hiding (insert)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Tuple
 import GHC.Generics
-
 import Network.Socket hiding (send, sendTo, recv, recvFrom, KeepAlive)
 import Network.Socket.ByteString.Lazy
-import Control.Exception
-import Data.Aeson hiding ((.=))
-import Data.Map (Map, (!), member, insert)
-import qualified Data.Map as Map
-import GHC.Generics
-
-import System.IO
-import System.IO.Error
-import System.FilePath
 import System.Directory
-import Data.IORef
-import Data.List hiding (insert)
-import Data.Tuple
-import Data.Maybe
-import Control.Applicative ((<|>))
-import Control.Monad
-import Control.Monad.State
-import Control.Concurrent.MVar
-import Control.Monad.IO.Class
 import System.Environment
-import Debug.Trace
+import System.IO
 
+import DynFlags
 import GHC hiding (loadModule)
-import Bag (bagToList)
-import SrcLoc (realSrcSpanStart)
-import ErrUtils (errMsgSpan)
-import DynFlags (gopt_set)
 import GHC.Paths ( libdir )
 import GhcMonad (GhcMonad(..), Session(..), reflectGhc, modifySession)
-import HscTypes (SourceError, srcErrorMessages, hsc_mod_graph)
-import FastString (unpackFS)
+import HscTypes (hsc_mod_graph)
+import Packages
 
 import Control.Reference
 
 import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.PrettyPrint
+import Language.Haskell.Tools.Refactor.Daemon.PackageDB
+import Language.Haskell.Tools.Refactor.Daemon.State
 import Language.Haskell.Tools.Refactor.GetModules
-import Language.Haskell.Tools.Refactor.Prepare
 import Language.Haskell.Tools.Refactor.Perform
+import Language.Haskell.Tools.Refactor.Prepare
 import Language.Haskell.Tools.Refactor.RefactorBase
 import Language.Haskell.Tools.Refactor.Session
-import Language.Haskell.Tools.PrettyPrint
-import Language.Haskell.Tools.Refactor.Daemon.State
 
 -- TODO: handle boot files
 
@@ -77,6 +66,7 @@        listen sock 1
        clientLoop isSilent sock
 
+defaultArgs :: [String]
 defaultArgs = ["4123", "True"]
 
 clientLoop :: Bool -> Socket -> IO ()
@@ -99,8 +89,8 @@          sessionData <- readMVar state
          when (not (sessionData ^. exiting) && all (== True) continue)
            $ serverLoop isSilent ghcSess state sock
-  `catch` interrupted sock
-  where interrupted = \s ex -> do
+  `catch` interrupted
+  where interrupted = \ex -> do
                         let err = show (ex :: IOException)
                         when (not isSilent) $ do
                           putStrLn "Closing down socket"
@@ -119,13 +109,16 @@ updateClient :: (ResponseMsg -> IO ()) -> ClientMessage -> StateT DaemonSessionState Ghc Bool
 updateClient resp KeepAlive = liftIO (resp KeepAliveResponse) >> return True
 updateClient resp Disconnect = liftIO (resp Disconnected) >> return False
+updateClient _ (SetPackageDB pkgDB) = modify (packageDB .= pkgDB) >> return True 
 updateClient resp (AddPackages packagePathes) = do
-    existing <- gets (map ms_mod . (^? refSessMCs & traversal & filtered isTheAdded & mcModules & traversal & modRecMS))
+    existingMCs <- gets (^. refSessMCs)
+    let existing = map ms_mod $ (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS)
     needToReload <- (filter (\ms -> not $ ms_mod ms `elem` existing)) 
                       <$> getReachableModules (\ms -> ms_mod ms `elem` existing)
     modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database
     forM_ existing $ \mn -> removeTarget (TargetModule (GHC.moduleName mn))
     modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) })
+    initializePackageDBIfNeeded
     res <- loadPackagesFrom (return . getModSumOrig) packagePathes
     case res of 
       Right (modules, ignoredMods) -> do
@@ -140,15 +133,21 @@       Left err -> liftIO $ resp $ CompilationProblem err 
     return True
   where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes
+        initializePackageDBIfNeeded = do
+          pkgDBAlreadySet <- gets (^. packageDBSet)
+          when (not pkgDBAlreadySet) $ do
+            pkgDB <- gets (^. packageDB)
+            pkgDBLocs <- liftIO $ packageDBLocs pkgDB packagePathes
+            usePackageDB pkgDBLocs
+            modify (packageDBSet .= True)
 
-updateClient resp (RemovePackages packagePathes) = do
+updateClient _ (RemovePackages packagePathes) = do
     mcs <- gets (^. refSessMCs)
     let existing = map ms_mod (mcs ^? traversal & filtered isRemoved & mcModules & traversal & modRecMS)
     lift $ forM_ existing (\modName -> removeTarget (TargetModule (GHC.moduleName modName)))
     lift $ deregisterDirs (mcs ^? traversal & filtered isRemoved & mcSourceDirs & traversal)
     modify $ refSessMCs .- filter (not . isRemoved)
     modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) })
-    mods <- lift getModuleGraph
     return True
   where isRemoved mc = (mc ^. mcRoot) `elem` packagePathes
 
@@ -158,8 +157,10 @@      modify $ refSessMCs & traversal & mcModules 
                 .- Map.filter (\m -> maybe True (not . (`elem` removed) . getModSumOrig) (m ^? modRecMS))
      modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` removedMods) . ms_mod) (hsc_mod_graph s) })
-     reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms]))
-                          (\ms -> getModSumOrig ms `elem` changed)
+     reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms]))
+                                       (\ms -> getModSumOrig ms `elem` changed)
+     liftIO $ case reloadRes of Left errs -> resp (CompilationProblem errs)
+                                Right _ -> return ()
      return True
 
 updateClient _ Stop = modify (exiting .= True) >> return False
@@ -172,6 +173,7 @@       Left err -> liftIO $ resp $ ErrorMessage err
       Right diff -> do changedMods <- catMaybes <$> applyChanges diff
                        liftIO $ resp $ ModulesChanged (map snd changedMods)
+                       -- when a new module is added, we need to compile it with the correct package db
                        void $ reloadChanges (map ((^. sfkModuleName) . fst) changedMods)
     return True
   where applyChanges changes = do 
@@ -204,13 +206,27 @@               return Nothing
           
         reloadChanges changedMods 
-          = reloadChangedModules (\ms -> resp $ LoadedModules [getModSumOrig ms]) (\ms -> modSumName ms `elem` changedMods)
+          = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms])) 
+                                                 (\ms -> modSumName ms `elem` changedMods)
+               liftIO $ case reloadRes of Left errs -> resp (ErrorMessage $ "The result of the refactoring contains errors: " ++ errs)
+                                          Right _ -> return ()
 
 initGhcSession :: IO Session
 initGhcSession = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags >> getSession))
 
+usePackageDB :: GhcMonad m => [FilePath] -> m ()
+usePackageDB [] = return ()
+usePackageDB pkgDbLocs
+  = do dfs <- getSessionDynFlags
+       dfs' <- liftIO $ fmap fst $ initPackages 
+                 $ dfs { extraPkgConfs = (map PkgConfFile pkgDbLocs ++) . extraPkgConfs dfs
+                       , pkgDatabase = Nothing 
+                       }
+       void $ setSessionDynFlags dfs'
+
 data ClientMessage
   = KeepAlive
+  | SetPackageDB { pkgDB :: PackageDB }
   | AddPackages { addedPathes :: [FilePath] }
   | RemovePackages { removedPathes :: [FilePath] }
   | PerformRefactoring { refactoring :: String
@@ -223,10 +239,7 @@   | ReLoad { changedModules :: [FilePath]
            , removedModules :: [FilePath]
            }
-  -- ReLoadAll -- re-load all modules
-  -- Reset -- completely re-initialize the refactor sesson
   deriving (Show, Generic)
-
 
 instance FromJSON ClientMessage 
 

@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveGeneric #-}
+module Language.Haskell.Tools.Refactor.Daemon.PackageDB where
+
+import Data.Aeson (FromJSON(..))
+import Data.Char (isSpace)
+import Data.List
+import GHC.Generics (Generic(..))
+import System.Directory (withCurrentDirectory, doesFileExist, doesDirectoryExist)
+import System.FilePath (FilePath(..), (</>))
+import System.Process (readProcessWithExitCode)
+
+data PackageDB = AutoDB
+               | DefaultDB
+               | CabalSandboxDB
+               | StackDB
+               | ExplicitDB { packageDBPath :: FilePath }
+  deriving (Show, Generic)
+
+instance FromJSON PackageDB
+
+packageDBLocs :: PackageDB -> [FilePath] -> IO [FilePath]
+packageDBLocs pack = fmap concat . mapM (packageDBLoc pack) 
+
+packageDBLoc :: PackageDB -> FilePath -> IO [FilePath]
+packageDBLoc AutoDB path = (++) <$> packageDBLoc StackDB path <*> packageDBLoc CabalSandboxDB path
+packageDBLoc DefaultDB _ = return []
+packageDBLoc CabalSandboxDB path = do
+  hasConfigFile <- doesFileExist (path </> "cabal.config")
+  hasSandboxFile <- doesFileExist (path </> "cabal.sandbox.config")
+  config <- if hasConfigFile then readFile (path </> "cabal.config")
+              else if hasSandboxFile then readFile (path </> "cabal.sandbox.config")
+                                     else return ""
+  return $ map (drop (length "package-db: ")) $ filter ("package-db: " `isPrefixOf`) $ lines config
+packageDBLoc StackDB path = withCurrentDirectory path $ do
+     (_, snapshotDB, snapshotDBErrs) <- readProcessWithExitCode "stack" ["path", "--snapshot-pkg-db"] ""
+     (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--local-pkg-db"] ""
+     return $ [trim localDB | null localDBErrs] ++ [trim snapshotDB | null snapshotDBErrs]
+packageDBLoc (ExplicitDB dir) path = do
+  hasDir <- doesDirectoryExist (path </> dir)
+  if hasDir then return [path </> dir]
+            else return []
+
+trim :: String -> String
+trim = f . f
+   where f = reverse . dropWhile isSpace

@@ -3,11 +3,13 @@ 
 import Control.Reference
 
-import Language.Haskell.Tools.Refactor.GetModules
+import Language.Haskell.Tools.Refactor.Daemon.PackageDB
 import Language.Haskell.Tools.Refactor.Session
 
 data DaemonSessionState 
   = DaemonSessionState { _refactorSession :: RefactorSessionState
+                       , _packageDB :: PackageDB
+                       , _packageDBSet :: Bool
                        , _exiting :: Bool
                        }
 
@@ -15,4 +17,4 @@ 
 instance IsRefactSessionState DaemonSessionState where
   refSessMCs = refactorSession & refSessMCs
-  initSession = DaemonSessionState initSession False+  initSession = DaemonSessionState initSession AutoDB False False

@@ -0,0 +1,1 @@+module A where

@@ -0,0 +1,3 @@+module A where
+
+import No.Such.Module

@@ -0,0 +1,4 @@+module A where
+
+a :: ()
+a = 4

@@ -1,7 +1,5 @@ module Main where
 
-import System.Environment
-
 import Language.Haskell.Tools.Refactor.Daemon
 
 main :: IO ()

@@ -1,5 +1,5 @@ name:                haskell-tools-daemon
-version:             0.4.1.1
+version:             0.4.1.3
 synopsis:            Background process for Haskell-tools refactor that editors can connect to.
 description:         Background process for Haskell-tools refactor that editors can connect to.
 homepage:            https://github.com/haskell-tools/haskell-tools
@@ -47,6 +47,9 @@                   , examples/Project/th-added-later/package1/*.cabal
                   , examples/Project/th-added-later/package2/*.hs
                   , examples/Project/th-added-later/package2/*.cabal
+                  , examples/Project/load-error/*.hs
+                  , examples/Project/source-error/*.hs
+                  , examples/Project/empty/*.hs
 
 library
   ghc-options:         -O2
@@ -57,7 +60,8 @@                      , containers                >= 0.5   && < 0.6
                      , mtl                       >= 2.2   && < 2.3
                      , split                     >= 0.2   && < 1.0
-                     , directory                 >= 1.2   && < 1.3
+                     , directory                 >= 1.2   && < 1.4
+                     , process                   >= 1.4   && < 1.5
                      , ghc                       >= 8.0   && < 8.1
                      , ghc-paths                 >= 0.1   && < 0.2
                      , references                >= 0.3.2 && < 1.0
@@ -67,6 +71,7 @@                      , haskell-tools-refactor    >= 0.4   && < 0.5
   exposed-modules:     Language.Haskell.Tools.Refactor.Daemon
                      , Language.Haskell.Tools.Refactor.Daemon.State
+                     , Language.Haskell.Tools.Refactor.Daemon.PackageDB
   default-language:    Haskell2010
 
 
@@ -87,7 +92,8 @@                      , HUnit                     >= 1.5  && < 1.6
                      , tasty                     >= 0.11 && < 0.12
                      , tasty-hunit               >= 0.9  && < 0.10
-                     , directory                 >= 1.2  && < 1.3
+                     , directory                 >= 1.2  && < 1.4
+                     , process                   >= 1.4  && < 1.5
                      , filepath                  >= 1.4  && < 2.0
                      , bytestring                >= 0.10 && < 0.11
                      , network                   >= 2.6  && < 2.7

@@ -1,4 +1,4 @@-{-# LANGUAGE StandaloneDeriving, LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving, LambdaCase, ScopedTypeVariables #-}
 module Main where
 
 import Test.Tasty
@@ -6,7 +6,9 @@ import System.Exit
 import System.Directory
 import System.FilePath
+import System.Process
 import System.Environment
+import System.Exit
 import Control.Monad
 import Control.Exception
 import Control.Concurrent
@@ -18,35 +20,42 @@ import Data.Aeson
 import Data.Maybe
 import System.IO
-import System.Directory
 
 import Debug.Trace
 
 import Language.Haskell.Tools.Refactor.Daemon
+import Language.Haskell.Tools.Refactor.Daemon.PackageDB
 
+pORT_NUM_START = 4100
+pORT_NUM_END = 4200
+
 main :: IO ()
-main = do -- create one daemon process for the whole testing session
-          -- with separate processes it is not a problem
-          forkIO $ runDaemon ["4123", "True"]
+main = do unsetEnv "GHC_PACKAGE_PATH"
+          portCounter <- newMVar pORT_NUM_START 
           tr <- canonicalizePath testRoot
-          isStackRun <- isJust <$> lookupEnv "STACK_ROOT"
-          defaultMain (allTests isStackRun tr)
-          stopDaemon
+          isStackRun <- isJust <$> lookupEnv "STACK_EXE"
+          defaultMain (allTests isStackRun tr portCounter)
 
-allTests :: Bool -> FilePath -> TestTree
-allTests isSource testRoot
-  = localOption (mkTimeout ({- 20s -} 1000 * 1000 * 20)) 
+allTests :: Bool -> FilePath -> MVar Int -> TestTree
+allTests isSource testRoot portCounter
+  = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) 
       $ testGroup "daemon-tests" 
           [ testGroup "simple-tests" 
-              $ map (makeDaemonTest . (\(label, input, output) -> (Nothing, label, input, output))) simpleTests
+              $ map (makeDaemonTest portCounter . (\(label, input, output) -> (Nothing, label, input, output))) simpleTests
           , testGroup "loading-tests" 
-              $ map (makeDaemonTest . (\(label, input, output) -> (Nothing, label, input, output))) loadingTests
+              $ map (makeDaemonTest portCounter . (\(label, input, output) -> (Nothing, label, input, output))) loadingTests
           , testGroup "refactor-tests" 
-              $ map (makeDaemonTest . (\(label, dir, input, output) -> (Just (testRoot </> dir), label, input, output))) (refactorTests testRoot)
+              $ map (makeDaemonTest portCounter . (\(label, dir, input, output) -> (Just (testRoot </> dir), label, input, output))) (refactorTests testRoot)
           , testGroup "reload-tests" 
-              $ map makeReloadTest reloadingTests
+              $ map (makeReloadTest portCounter) reloadingTests
+          , testGroup "compilation-problem-tests" 
+              $ map (makeCompProblemTest portCounter) compProblemTests
+          -- if not a stack build, we cannot guarantee that stack is on the path
+          , if isSource
+             then testGroup "pkg-db-tests" $ map (makePkgDbTest portCounter) pkgDbTests
+             else testCase "IGNORED pkg-db-tests" (return ())
           -- cannot execute this when the source is not present
-          , if isSource then selfLoadingTest else testCase "IGNORED self-load" (return ())
+          , if isSource then selfLoadingTest portCounter else testCase "IGNORED self-load" (return ())
           ]
 
 testSuffix = "_test"
@@ -91,18 +100,40 @@     , [LoadedModules [testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs"]] )
   , ( "th-added-later"
     , [ AddPackages [testRoot </> "th-added-later" </> "package1"]
-      , AddPackages [testRoot </> "th-added-later" </> "package2"] 
+      , AddPackages [testRoot </> "th-added-later" </> "package2"]
       ]
     , [ LoadedModules [testRoot </> "th-added-later" </> "package1" </> "A.hs"] 
       , LoadedModules [testRoot </> "th-added-later" </> "package2" </> "B.hs"]] )
   ]
 
+compProblemTests :: [(String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)]
+compProblemTests = 
+  [ ( "load-error"
+    , [ Right $ AddPackages [testRoot </> "load-error"] ] 
+    , \case [CompilationProblem {}] -> True; _ -> False)
+  , ( "source-error"
+    , [ Right $ AddPackages [testRoot </> "source-error"] ] 
+    , \case [CompilationProblem {}] -> True; _ -> False)
+  , ( "reload-error"
+    , [ Right $ AddPackages [testRoot </> "empty"] 
+      , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\nimport No.Such.Module"
+      , Right $ ReLoad [testRoot </> "empty" </> "A.hs"] [] 
+      , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"]
+    , \case [LoadedModules {}, CompilationProblem {}] -> True; _ -> False)
+  , ( "reload-source-error"
+    , [ Right $ AddPackages [testRoot </> "empty"] 
+      , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\naa = 3 + ()"
+      , Right $ ReLoad [testRoot </> "empty" </> "A.hs"] [] 
+      , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"]
+    , \case [LoadedModules {}, CompilationProblem {}] -> True; _ -> False)
+  ]
+
 sourceRoot = ".." </> ".." </> "src"
 
-selfLoadingTest :: TestTree
-selfLoadingTest = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do  
-    actual <- communicateWithDaemon 
-                [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor", "daemon"] ) ]
+selfLoadingTest :: MVar Int -> TestTree
+selfLoadingTest port = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do  
+    actual <- communicateWithDaemon port
+                [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor", "daemon"]) ]
     assertBool ("The expected result is a nonempty response message list that does not contain errors. Actual result: " ++ show actual) 
                (not (null actual) && all (\case ErrorMessage {} -> False; _ -> True) actual)
 
@@ -142,7 +173,7 @@ 
 reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg])]
 reloadingTests =
-  [ ( "reloading-module", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ] ]
+  [ ( "reloading-module", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]]
     , writeFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") "module C where\nc = ()" 
     , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "C.hs"] []
       , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "2:1-2:2" ["d"] 
@@ -161,7 +192,7 @@       ]
     )
   , ( "reloading-package", testRoot </> "changing-cabal"
-    , [ AddPackages [ testRoot </> "changing-cabal" ++ testSuffix ] ]
+    , [ AddPackages [ testRoot </> "changing-cabal" ++ testSuffix ]]
     , appendFile (testRoot </> "changing-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" 
     , [ AddPackages [testRoot </> "changing-cabal" ++ testSuffix]
       , PerformRefactoring "RenameDefinition" (testRoot </> "changing-cabal" ++ testSuffix </> "A.hs") "3:1-3:2" ["z"] 
@@ -175,7 +206,7 @@       , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ]
       ]
     )
-  , ( "reloading-remove", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ] ]
+  , ( "reloading-remove", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]]
     , do removeFile (testRoot </> "reloading" ++ testSuffix </> "A.hs")
          removeFile (testRoot </> "reloading" ++ testSuffix </> "B.hs")
     , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "C.hs"] 
@@ -206,45 +237,124 @@     )
   ]
 
-makeDaemonTest :: (Maybe FilePath, String, [ClientMessage], [ResponseMsg]) -> TestTree
-makeDaemonTest (Nothing, label, input, expected) = testCase label $ do  
-    actual <- communicateWithDaemon (map Right input)
+pkgDbTests :: [(String, IO (), [ClientMessage], [ResponseMsg])]
+pkgDbTests 
+  = [ ( "stack"
+       , withCurrentDirectory (testRoot </> "stack") initStack
+       , [SetPackageDB StackDB, AddPackages [testRoot </> "stack"]]
+       , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] )
+    , ( "cabal-sandbox"
+      , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox
+      , [SetPackageDB CabalSandboxDB, AddPackages [testRoot </> "cabal-sandbox"]]
+      , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] )
+    , ( "cabal-sandbox-auto"
+      , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox
+      , [SetPackageDB AutoDB, AddPackages [testRoot </> "cabal-sandbox"]]
+      , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] )
+    , ( "stack-auto"
+      , withCurrentDirectory (testRoot </> "stack") initStack
+      , [SetPackageDB AutoDB, AddPackages [testRoot </> "stack"]]
+      , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] )
+    , ( "pkg-db-reload"
+      , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox
+      , [ SetPackageDB AutoDB
+        , AddPackages [testRoot </> "cabal-sandbox"]
+        , ReLoad [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] []]
+      , [ LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]
+        , LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] ])
+    ] 
+  where initCabalSandbox = do
+          sandboxExists <- doesDirectoryExist ".cabal-sandbox"
+          when sandboxExists $ tryToExecute "cabal" ["sandbox", "delete"]
+          execute "cabal" ["sandbox", "init"]
+          withCurrentDirectory ("groups-0.4.0.0") $ do
+            execute "cabal" ["sandbox", "init", "--sandbox", ".." </> ".cabal-sandbox"]
+            execute "cabal" ["install"]
+        initStack = do
+          execute "stack" ["clean"]
+          execute "stack" ["build"]
+
+
+execute :: String -> [String] -> IO ()
+execute cmd args 
+  = do let command = (cmd ++ concat (map (" " ++) args))
+       (_, Just stdOut, Just stdErr, handle) <- createProcess ((shell command) { std_out = CreatePipe, std_err = CreatePipe })
+       exitCode <- waitForProcess handle
+       when (exitCode /= ExitSuccess) $ do 
+         output <- hGetContents stdOut
+         errors <- hGetContents stdErr
+         error ("Command exited with nonzero: " ++ command ++ " output:\n" ++ output ++ "\nerrors:\n" ++ errors)
+
+tryToExecute :: String -> [String] -> IO ()
+tryToExecute cmd args 
+  = do let command = (cmd ++ concat (map (" " ++) args))
+       (_, _, _, handle) <- createProcess ((shell command) { std_out = NoStream, std_err = NoStream })
+       void $ waitForProcess handle
+
+makeDaemonTest :: MVar Int -> (Maybe FilePath, String, [ClientMessage], [ResponseMsg]) -> TestTree
+makeDaemonTest port (Nothing, label, input, expected) = testCase label $ do  
+    actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input))
     assertEqual "" expected actual
-makeDaemonTest (Just dir, label, input, expected) = testCase label $ do 
+makeDaemonTest port (Just dir, label, input, expected) = testCase label $ do 
     exists <- doesDirectoryExist (dir ++ testSuffix)
     -- clear the target directory from possible earlier test runs
     when exists $ removeDirectoryRecursive (dir ++ testSuffix)
     copyDir dir (dir ++ testSuffix)
-    actual <- communicateWithDaemon (map Right input)
+    actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input))
     assertEqual "" expected actual
   `finally` removeDirectoryRecursive (dir ++ testSuffix)
 
-makeReloadTest :: (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg]) -> TestTree
-makeReloadTest (label, dir, input1, io, input2, expected) = testCase label $ do  
+makeReloadTest :: MVar Int -> (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg]) -> TestTree
+makeReloadTest port (label, dir, input1, io, input2, expected) = testCase label $ do  
     exists <- doesDirectoryExist (dir ++ testSuffix)
     -- clear the target directory from possible earlier test runs
     when exists $ removeDirectoryRecursive (dir ++ testSuffix)
     copyDir dir (dir ++ testSuffix)
-    actual <- communicateWithDaemon (map Right input1 ++ [Left io] ++ map Right input2)
+    actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input1) ++ [Left io] ++ map Right input2)
     assertEqual "" expected actual
   `finally` removeDirectoryRecursive (dir ++ testSuffix)
 
-communicateWithDaemon :: [Either (IO ()) ClientMessage] -> IO [ResponseMsg]
-communicateWithDaemon msgs = withSocketsDo $ do
-  addrInfo <- getAddrInfo Nothing (Just "127.0.0.1") (Just "4123")
-  let serverAddr = head addrInfo
-  sock <- socket (addrFamily serverAddr) Stream defaultProtocol
-  connect sock (addrAddress serverAddr)
-  intermedRes <- sequence (map (either (\io -> do sendAll sock (encode KeepAlive)
-                                                  r <- readSockResponsesUntil sock KeepAliveResponse BS.empty
-                                                  io
-                                                  return r)
-                               ((>> return []) . sendAll sock . (`BS.snoc` '\n') . encode)) msgs)
-  sendAll sock $ encode Disconnect
-  resps <- readSockResponsesUntil sock Disconnected BS.empty
-  close sock
-  return (concat intermedRes ++ resps)
+makePkgDbTest :: MVar Int -> (String, IO (), [ClientMessage], [ResponseMsg]) -> TestTree
+makePkgDbTest port (label, prepare, inputs, expected) 
+  = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) 
+      $ testCase label $ do  
+          actual <- communicateWithDaemon port ([Left prepare] ++ map Right inputs)
+          assertEqual "" expected actual
 
+makeCompProblemTest :: MVar Int -> (String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool) -> TestTree
+makeCompProblemTest port (label, actions, validator) = testCase label $ do
+  actual <- communicateWithDaemon port actions
+  assertBool ("The responses are not the expected: " ++ show actual) (validator actual)
+
+communicateWithDaemon :: MVar Int -> [Either (IO ()) ClientMessage] -> IO [ResponseMsg]
+communicateWithDaemon port msgs = withSocketsDo $ do
+    portNum <- retryConnect port
+    addrInfo <- getAddrInfo Nothing (Just "127.0.0.1") (Just (show portNum))
+    let serverAddr = head addrInfo
+    sock <- socket (addrFamily serverAddr) Stream defaultProtocol
+    waitToConnect sock (addrAddress serverAddr)
+    intermedRes <- sequence (map (either (\io -> do sendAll sock (encode KeepAlive)
+                                                    r <- readSockResponsesUntil sock KeepAliveResponse BS.empty
+                                                    io
+                                                    return r)
+                                 ((>> return []) . sendAll sock . (`BS.snoc` '\n') . encode)) msgs)
+    sendAll sock $ encode Disconnect
+    resps <- readSockResponsesUntil sock Disconnected BS.empty
+    sendAll sock $ encode Stop
+    close sock
+    return (concat intermedRes ++ resps)
+  where waitToConnect sock addr 
+          = connect sock addr `catch` \(e :: SomeException) -> waitToConnect sock addr
+        retryConnect port = do portNum <- readMVar port 
+                               forkIO $ runDaemon [show portNum, "True"]
+                               return portNum
+          `catch` \(e :: SomeException) -> do putStrLn ("exception caught: `" ++ show e ++ "` trying with a new port")
+                                              modifyMVar_ port (\i -> if i < pORT_NUM_END 
+                                                                        then return (i+1) 
+                                                                        else error "The port number reached the maximum")
+                                              retryConnect port
+
+
 readSockResponsesUntil :: Socket -> ResponseMsg -> BS.ByteString -> IO [ResponseMsg]
 readSockResponsesUntil sock rsp bs
   = do resp <- recv sock 2048
@@ -258,21 +368,12 @@                  then return $ List.delete rsp recognized 
                  else readSockResponsesUntil sock rsp fullBS
 
-stopDaemon :: IO ()
-stopDaemon = withSocketsDo $ do
-  addrInfo <- getAddrInfo Nothing (Just "127.0.0.1") (Just "4123")
-  let serverAddr = head addrInfo
-  sock <- socket (addrFamily serverAddr) Stream defaultProtocol
-  connect sock (addrAddress serverAddr)
-
-  sendAll sock $ encode Stop
-  close sock
-
 testRoot = "examples" </> "Project"
 
 deriving instance Eq ResponseMsg
 instance FromJSON ResponseMsg
 instance ToJSON ClientMessage
+instance ToJSON PackageDB
 
 copyDir ::  FilePath -> FilePath -> IO ()
 copyDir src dst = do