Ticket #6017: 0001-Add-a-blacklist-whitelist-mechanism-for-.ghci-files-.patch

ghc/InteractiveUI.hs

@@ -72 +72 @@
 import Data.Char
 import Data.Function
 import Data.IORef ( IORef, readIORef, writeIORef )
-import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
-                   partition, sort, sortBy )
+import Data.List ( dropWhileEnd, find, group, intercalate, intersperse, isPrefixOf,
+                   nub, partition, sort, sortBy )
 import Data.Maybe
 
 import Exception hiding (catch)
@@ -420 +420 @@
                right dir
         _ -> left
 
-runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
-runGHCi paths maybe_exprs = do
-  dflags <- getDynFlags
-  let
-   read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
-
-   current_dir = return (Just ".ghci")
+-- | Check if a filename is mentioned in a whitelist or blacklist file.
+filenameInListFile :: FilePath    -- ^ Whitelist or blacklist filename
+                   -> FilePath    -- ^ Path to check
+                   -> String      -- ^ Description of list file, for errors
+                   -> IO Bool
+filenameInListFile list_fn target_path descr = do
+  cp <- checkPerms list_fn
+  if (not cp)
+    then return False
+    else do
+      either_hdl <- liftIO $ tryIO (openFile list_fn ReadMode)
+      case either_hdl of
+        Left err -> do
+          -- If we can't read the list file that shouldn't abort GHCi, but the
+          -- user might want to know why the whitelist/blacklist mechanism
+          -- doesn't work.
+          when (not $ isDoesNotExistError err) $
+            putStrLn ("WARNING: Error while opening " ++ descr ++ " file \""
+                      ++ list_fn ++ "\": " ++ (ioeGetErrorString err))
+          return False
+        Right hdl -> do
+          found <- checkLoop hdl
+          hClose hdl
+          return found
+  where
+    checkLoop hdl = do
+      -- hGetLine only fails on EOF
+      maybe_line <- liftM Just (hGetLine hdl) `catchIO` \_ -> return Nothing
+      case maybe_line of
+        Nothing -> return False
+        Just l -> do
+          -- Avoid problems with users editing whitelist/blacklist and
+          -- accidentally adding spaces at the end of line. This may cause
+          -- problems with technically valid filenames under Windows but
+          -- such files would give problems with a whole lot of other
+          -- programs (including normal Windows tools) as well. 
+          let p = dropWhileEnd isSpace $ l
+          if target_path == p
+            then return True
+            else checkLoop hdl
+
+-- | The user asking part of getAllowDotGhciChoice.
+--
+-- This is factored out because if the app user dir (~/.ghc on Linux) isn't
+-- available the security mechanism should still work.
+askAllowDotGhciChoice :: FilePath -> IO Bool
+askAllowDotGhciChoice dotghci_fn = runInputT defaultSettings $ do
+  outputStrLn ("File \"" ++ dotghci_fn ++ "\" contains commands to " ++
+               "customize your ghci session. This is a potential security " ++
+               "risk, executing the file may cause arbitrary code to be " ++
+               "run on your system.")
+  getChoice
+  where
+    getChoice = do
+      mch <- getInputChar ("Do you want to allow \"" ++ dotghci_fn ++ 
+                           "\" to be loaded? [Y/N] ")
+      case mch of
+        Just ch | ch == 'y' || ch == 'Y' -> return True
+                | ch == 'n' || ch == 'N' -> return False
+        _ -> do
+          outputStrLn "Please choose 'y' or 'n'."
+          getChoice
+
+-- | Ask the user whether a .ghci file should be loaded and save the
+--   choice.
+getAllowDotGhciChoice :: FilePath -> FilePath -> IO Bool
+getAllowDotGhciChoice app_user_dir dotghci_fn = do 
+  choice <- askAllowDotGhciChoice dotghci_fn
+  addToListFile (if choice then "whitelist" else "blacklist")
+                (if choice then "ghci_whitelist" else "ghci_blacklist")
+  return choice
+  where
+    addToListFile list_name list_fn = do
+      let list_afn = app_user_dir </> list_fn
+      -- Temporarily set the umask so that
+#ifdef mingw32_HOST_OS
+      res <- tryIO $ appendFile list_fn (dotghci_fn ++ "\n")
+#else
+      -- Use low level calls to set the right mode without a race
+      -- condition (which would happen with setFileMode).
+      let mode = ownerReadMode `unionFileModes` ownerWriteMode
+      res <- tryIO $ do
+        fd <- openFd list_afn WriteOnly (Just mode) 
+                     (defaultFileFlags { append = True })
+        let line = dotghci_fn ++ "\n"        
+        written <- fdWrite fd line
+        closeFd fd
+        when (fromIntegral written /= length line) $
+          ioError $ userError "Incomplete write"
+#endif
+      case res of
+        Left err -> putStrLn ("WARNING: Could not write to \"" ++ list_fn ++
+                              "\": " ++ ioeGetErrorString err)
+        Right _ -> putStrLn ("\"" ++ dotghci_fn ++ "\" has been added " ++
+                             "to the " ++ list_name ++ " at \"" ++
+                             list_afn ++ "\".")
+
+-- | Determine if the passed .ghci file is allowed, asking the user if
+--   necessary.
+--
+-- This should only be called for .ghci files that are not trusted.
+--
+-- The filepath should already have been canonicalized.
+getDotGhciAllowed :: Maybe FilePath -> Bool -> FilePath -> IO Bool
+getDotGhciAllowed Nothing _ dotghci_fn = do
+  choice <- askAllowDotGhciChoice dotghci_fn
+  putStrLn ("Could not save your choice. The user application directory " ++
+            "does not exist and could not be created.")
+  return choice
+getDotGhciAllowed (Just app_user_dir) is_interactive dotghci_fn = do
+  is_blacklisted <- filenameInListFile (app_user_dir </> "ghci_blacklist") 
+                                       dotghci_fn "blacklist"
+  if is_blacklisted
+    then return False
+    else do
+      is_whitelisted <- filenameInListFile (app_user_dir </> "ghci_whitelist")
+                                           dotghci_fn "whitelist"
+      if is_whitelisted
+        then return True
+        else if is_interactive
+               then getAllowDotGhciChoice app_user_dir dotghci_fn
+               -- Can't ask the user when invoked as "ghc -e" (user might
+               -- be using stdout and stderr for his/her own purposes), 
+               -- so assume not allowed.
+               else return False
+
+-- Read a config file. 
+--
+sourceConfigFile :: Maybe FilePath -> Bool -> Bool -> FilePath -> GHCi ()
+sourceConfigFile app_user_dir is_interactive is_trusted file = do
+  exists <- liftIO $ doesFileExist file
+  when exists $ do
+    dir_ok  <- liftIO $ checkPerms (getDirectory file)
+    file_ok <- liftIO $ checkPerms file
+    when (dir_ok && file_ok) $ do
+      allowed <- if is_trusted 
+                    then return True
+                    else liftIO $ getDotGhciAllowed app_user_dir 
+                                                    is_interactive file
+      if not allowed
+        then when is_interactive $
+              liftIO $ putStrLn ("Not reading blacklisted .ghci file \"" ++ 
+                                 file ++ "\".")
+        else do
+          either_hdl <- liftIO $ tryIO (openFile file ReadMode)
+          case either_hdl of
+            Left _e   -> return ()
+            -- NOTE: this assumes that runInputT won't affect the terminal;
+            -- can we assume this will always be the case?
+            -- This would be a good place for runFileInputT.
+            Right hdl ->
+                do runInputTWithPrefs defaultPrefs defaultSettings $
+                             runCommands $ fileLoop hdl
+                   liftIO (hClose hdl `catchIO` \_ -> return ())
+  where
+   getDirectory f = case takeDirectory f of "" -> "."; d -> d
 
-   app_user_dir = liftIO $ withGhcAppData
-                    (\dir -> return (Just (dir </> "ghci.conf")))
+-- | Given the extra script arguments load the .ghci and ghci.conf files.
+readDotFiles :: Bool -> [FilePath] -> GHCi ()
+readDotFiles is_interactive scripts = do
+  app_user_dir <- liftIO $ withGhcAppData
+                    (\dir -> return (Just dir))
                     (return Nothing)
-
-   home_dir = do
+  home_df <- do
     either_dir <- liftIO $ tryIO (getEnv "HOME")
     case either_dir of
       Right home -> return (Just (home </> ".ghci"))
       _ -> return Nothing
+                    
+  let
+    app_user_df = (</> "ghci.conf") `fmap` app_user_dir
+    current_df = ".ghci"
+
+    canonicalizePath' :: FilePath -> IO (Maybe FilePath)
+    canonicalizePath' fp = liftM Just (canonicalizePath fp)
+                 `catchIO` \_ -> return Nothing
+
+    trusted_dfs = catMaybes [app_user_df, home_df] ++ scripts
+
+  trusted_dfs_canon <- liftIO $ (nub . catMaybes) `fmap`
+      mapM canonicalizePath' trusted_dfs
+      -- nub, because we don't want to read .ghci twice if it is passed
+      -- as a -ghci-script.
+
+    -- If the current dir dot file filename is the same as a filename
+    -- considered trusted (like ~/.ghci) don't bother asking the user if
+    -- it should be trusted.
+  current_df_canon <- liftIO $ canonicalizePath' current_df
+  case current_df_canon of
+    Nothing -> return ()
+    Just f -> when (not (f `elem` trusted_dfs_canon)) $
+      sourceConfigFile app_user_dir is_interactive False f
+  mapM_ (sourceConfigFile app_user_dir is_interactive True) trusted_dfs
 
-   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
-   canonicalizePath' fp = liftM Just (canonicalizePath fp)
-                `catchIO` \_ -> return Nothing
-
-   sourceConfigFile :: FilePath -> GHCi ()
-   sourceConfigFile file = do
-     exists <- liftIO $ doesFileExist file
-     when exists $ do
-       dir_ok  <- liftIO $ checkPerms (getDirectory file)
-       file_ok <- liftIO $ checkPerms file
-       when (dir_ok && file_ok) $ do
-         either_hdl <- liftIO $ tryIO (openFile file ReadMode)
-         case either_hdl of
-           Left _e   -> return ()
-           -- NOTE: this assumes that runInputT won't affect the terminal;
-           -- can we assume this will always be the case?
-           -- This would be a good place for runFileInputT.
-           Right hdl ->
-               do runInputTWithPrefs defaultPrefs defaultSettings $
-                            runCommands $ fileLoop hdl
-                  liftIO (hClose hdl `catchIO` \_ -> return ())
-     where
-      getDirectory f = case takeDirectory f of "" -> "."; d -> d
-  --
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
+runGHCi paths maybe_exprs = do
+  dflags <- getDynFlags
+  let
+   read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
 
   setGHCContextFromGHCiState
 
-  when (read_dot_files) $ do
-    mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
-    mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
-    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
-        -- nub, because we don't want to read .ghci twice if the
-        -- CWD is $HOME.
+  -- The current dir dot file is not automatically trusted unless the
+  -- current dir is the app user dir or home dir or the current dir dot
+  -- file is also passed as a script argument.
+  when (read_dot_files) $
+    readDotFiles (not (isJust maybe_exprs)) (ghciScripts dflags)
 
   -- Perform a :load for files given on the GHCi command line
   -- When in -e mode, if the load fails then we want to stop