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

File 0001-Add-a-blacklist-whitelist-mechanism-for-.ghci-files-.patch, 11.9 KB (added by pminten, 3 years ago)
  • ghc/InteractiveUI.hs

    From fbab22ab493a222ea18b4b31e30a17467e0f3024 Mon Sep 17 00:00:00 2001
    From: Peter Minten <[email protected]>
    Date: Mon, 19 Nov 2012 13:14:10 +0100
    Subject: [PATCH 1/2] Add a blacklist/whitelist mechanism for .ghci files
     (#6017)
    
    Loading .ghci files from a non-trusted location could cause malicious code to be
    executed. Make ghci ask for confirmation and store the answer in ghci_blacklist
    or ghci_whitelist in the ghc app dir.
    ---
     ghc/InteractiveUI.hs | 242 ++++++++++++++++++++++++++++++++++++++++++---------
     1 file changed, 199 insertions(+), 43 deletions(-)
    
    diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
    index 5793080..37fd39d 100644
    a b import qualified Data.ByteString.Char8 as BS 
    7272import Data.Char
    7373import Data.Function
    7474import Data.IORef ( IORef, readIORef, writeIORef )
    75 import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
    76                    partition, sort, sortBy )
     75import Data.List ( dropWhileEnd, find, group, intercalate, intersperse, isPrefixOf,
     76                   nub, partition, sort, sortBy )
    7777import Data.Maybe
    7878
    7979import Exception hiding (catch)
    withGhcAppData right left = do 
    420420               right dir
    421421        _ -> left
    422422
    423 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
    424 runGHCi paths maybe_exprs = do
    425   dflags <- getDynFlags
    426   let
    427    read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
    428 
    429    current_dir = return (Just ".ghci")
     423-- | Check if a filename is mentioned in a whitelist or blacklist file.
     424filenameInListFile :: FilePath    -- ^ Whitelist or blacklist filename
     425                   -> FilePath    -- ^ Path to check
     426                   -> String      -- ^ Description of list file, for errors
     427                   -> IO Bool
     428filenameInListFile list_fn target_path descr = do
     429  cp <- checkPerms list_fn
     430  if (not cp)
     431    then return False
     432    else do
     433      either_hdl <- liftIO $ tryIO (openFile list_fn ReadMode)
     434      case either_hdl of
     435        Left err -> do
     436          -- If we can't read the list file that shouldn't abort GHCi, but the
     437          -- user might want to know why the whitelist/blacklist mechanism
     438          -- doesn't work.
     439          when (not $ isDoesNotExistError err) $
     440            putStrLn ("WARNING: Error while opening " ++ descr ++ " file \""
     441                      ++ list_fn ++ "\": " ++ (ioeGetErrorString err))
     442          return False
     443        Right hdl -> do
     444          found <- checkLoop hdl
     445          hClose hdl
     446          return found
     447  where
     448    checkLoop hdl = do
     449      -- hGetLine only fails on EOF
     450      maybe_line <- liftM Just (hGetLine hdl) `catchIO` \_ -> return Nothing
     451      case maybe_line of
     452        Nothing -> return False
     453        Just l -> do
     454          -- Avoid problems with users editing whitelist/blacklist and
     455          -- accidentally adding spaces at the end of line. This may cause
     456          -- problems with technically valid filenames under Windows but
     457          -- such files would give problems with a whole lot of other
     458          -- programs (including normal Windows tools) as well.
     459          let p = dropWhileEnd isSpace $ l
     460          if target_path == p
     461            then return True
     462            else checkLoop hdl
     463
     464-- | The user asking part of getAllowDotGhciChoice.
     465--
     466-- This is factored out because if the app user dir (~/.ghc on Linux) isn't
     467-- available the security mechanism should still work.
     468askAllowDotGhciChoice :: FilePath -> IO Bool
     469askAllowDotGhciChoice dotghci_fn = runInputT defaultSettings $ do
     470  outputStrLn ("File \"" ++ dotghci_fn ++ "\" contains commands to " ++
     471               "customize your ghci session. This is a potential security " ++
     472               "risk, executing the file may cause arbitrary code to be " ++
     473               "run on your system.")
     474  getChoice
     475  where
     476    getChoice = do
     477      mch <- getInputChar ("Do you want to allow \"" ++ dotghci_fn ++
     478                           "\" to be loaded? [Y/N] ")
     479      case mch of
     480        Just ch | ch == 'y' || ch == 'Y' -> return True
     481                | ch == 'n' || ch == 'N' -> return False
     482        _ -> do
     483          outputStrLn "Please choose 'y' or 'n'."
     484          getChoice
     485
     486-- | Ask the user whether a .ghci file should be loaded and save the
     487--   choice.
     488getAllowDotGhciChoice :: FilePath -> FilePath -> IO Bool
     489getAllowDotGhciChoice app_user_dir dotghci_fn = do
     490  choice <- askAllowDotGhciChoice dotghci_fn
     491  addToListFile (if choice then "whitelist" else "blacklist")
     492                (if choice then "ghci_whitelist" else "ghci_blacklist")
     493  return choice
     494  where
     495    addToListFile list_name list_fn = do
     496      let list_afn = app_user_dir </> list_fn
     497      -- Temporarily set the umask so that
     498#ifdef mingw32_HOST_OS
     499      res <- tryIO $ appendFile list_fn (dotghci_fn ++ "\n")
     500#else
     501      -- Use low level calls to set the right mode without a race
     502      -- condition (which would happen with setFileMode).
     503      let mode = ownerReadMode `unionFileModes` ownerWriteMode
     504      res <- tryIO $ do
     505        fd <- openFd list_afn WriteOnly (Just mode)
     506                     (defaultFileFlags { append = True })
     507        let line = dotghci_fn ++ "\n"       
     508        written <- fdWrite fd line
     509        closeFd fd
     510        when (fromIntegral written /= length line) $
     511          ioError $ userError "Incomplete write"
     512#endif
     513      case res of
     514        Left err -> putStrLn ("WARNING: Could not write to \"" ++ list_fn ++
     515                              "\": " ++ ioeGetErrorString err)
     516        Right _ -> putStrLn ("\"" ++ dotghci_fn ++ "\" has been added " ++
     517                             "to the " ++ list_name ++ " at \"" ++
     518                             list_afn ++ "\".")
     519
     520-- | Determine if the passed .ghci file is allowed, asking the user if
     521--   necessary.
     522--
     523-- This should only be called for .ghci files that are not trusted.
     524--
     525-- The filepath should already have been canonicalized.
     526getDotGhciAllowed :: Maybe FilePath -> Bool -> FilePath -> IO Bool
     527getDotGhciAllowed Nothing _ dotghci_fn = do
     528  choice <- askAllowDotGhciChoice dotghci_fn
     529  putStrLn ("Could not save your choice. The user application directory " ++
     530            "does not exist and could not be created.")
     531  return choice
     532getDotGhciAllowed (Just app_user_dir) is_interactive dotghci_fn = do
     533  is_blacklisted <- filenameInListFile (app_user_dir </> "ghci_blacklist")
     534                                       dotghci_fn "blacklist"
     535  if is_blacklisted
     536    then return False
     537    else do
     538      is_whitelisted <- filenameInListFile (app_user_dir </> "ghci_whitelist")
     539                                           dotghci_fn "whitelist"
     540      if is_whitelisted
     541        then return True
     542        else if is_interactive
     543               then getAllowDotGhciChoice app_user_dir dotghci_fn
     544               -- Can't ask the user when invoked as "ghc -e" (user might
     545               -- be using stdout and stderr for his/her own purposes),
     546               -- so assume not allowed.
     547               else return False
     548
     549-- Read a config file.
     550--
     551sourceConfigFile :: Maybe FilePath -> Bool -> Bool -> FilePath -> GHCi ()
     552sourceConfigFile app_user_dir is_interactive is_trusted file = do
     553  exists <- liftIO $ doesFileExist file
     554  when exists $ do
     555    dir_ok  <- liftIO $ checkPerms (getDirectory file)
     556    file_ok <- liftIO $ checkPerms file
     557    when (dir_ok && file_ok) $ do
     558      allowed <- if is_trusted
     559                    then return True
     560                    else liftIO $ getDotGhciAllowed app_user_dir
     561                                                    is_interactive file
     562      if not allowed
     563        then when is_interactive $
     564              liftIO $ putStrLn ("Not reading blacklisted .ghci file \"" ++
     565                                 file ++ "\".")
     566        else do
     567          either_hdl <- liftIO $ tryIO (openFile file ReadMode)
     568          case either_hdl of
     569            Left _e   -> return ()
     570            -- NOTE: this assumes that runInputT won't affect the terminal;
     571            -- can we assume this will always be the case?
     572            -- This would be a good place for runFileInputT.
     573            Right hdl ->
     574                do runInputTWithPrefs defaultPrefs defaultSettings $
     575                             runCommands $ fileLoop hdl
     576                   liftIO (hClose hdl `catchIO` \_ -> return ())
     577  where
     578   getDirectory f = case takeDirectory f of "" -> "."; d -> d
    430579
    431    app_user_dir = liftIO $ withGhcAppData
    432                     (\dir -> return (Just (dir </> "ghci.conf")))
     580-- | Given the extra script arguments load the .ghci and ghci.conf files.
     581readDotFiles :: Bool -> [FilePath] -> GHCi ()
     582readDotFiles is_interactive scripts = do
     583  app_user_dir <- liftIO $ withGhcAppData
     584                    (\dir -> return (Just dir))
    433585                    (return Nothing)
    434 
    435    home_dir = do
     586  home_df <- do
    436587    either_dir <- liftIO $ tryIO (getEnv "HOME")
    437588    case either_dir of
    438589      Right home -> return (Just (home </> ".ghci"))
    439590      _ -> return Nothing
     591                   
     592  let
     593    app_user_df = (</> "ghci.conf") `fmap` app_user_dir
     594    current_df = ".ghci"
     595
     596    canonicalizePath' :: FilePath -> IO (Maybe FilePath)
     597    canonicalizePath' fp = liftM Just (canonicalizePath fp)
     598                 `catchIO` \_ -> return Nothing
     599
     600    trusted_dfs = catMaybes [app_user_df, home_df] ++ scripts
     601
     602  trusted_dfs_canon <- liftIO $ (nub . catMaybes) `fmap`
     603      mapM canonicalizePath' trusted_dfs
     604      -- nub, because we don't want to read .ghci twice if it is passed
     605      -- as a -ghci-script.
     606
     607    -- If the current dir dot file filename is the same as a filename
     608    -- considered trusted (like ~/.ghci) don't bother asking the user if
     609    -- it should be trusted.
     610  current_df_canon <- liftIO $ canonicalizePath' current_df
     611  case current_df_canon of
     612    Nothing -> return ()
     613    Just f -> when (not (f `elem` trusted_dfs_canon)) $
     614      sourceConfigFile app_user_dir is_interactive False f
     615  mapM_ (sourceConfigFile app_user_dir is_interactive True) trusted_dfs
    440616
    441    canonicalizePath' :: FilePath -> IO (Maybe FilePath)
    442    canonicalizePath' fp = liftM Just (canonicalizePath fp)
    443                 `catchIO` \_ -> return Nothing
    444 
    445    sourceConfigFile :: FilePath -> GHCi ()
    446    sourceConfigFile file = do
    447      exists <- liftIO $ doesFileExist file
    448      when exists $ do
    449        dir_ok  <- liftIO $ checkPerms (getDirectory file)
    450        file_ok <- liftIO $ checkPerms file
    451        when (dir_ok && file_ok) $ do
    452          either_hdl <- liftIO $ tryIO (openFile file ReadMode)
    453          case either_hdl of
    454            Left _e   -> return ()
    455            -- NOTE: this assumes that runInputT won't affect the terminal;
    456            -- can we assume this will always be the case?
    457            -- This would be a good place for runFileInputT.
    458            Right hdl ->
    459                do runInputTWithPrefs defaultPrefs defaultSettings $
    460                             runCommands $ fileLoop hdl
    461                   liftIO (hClose hdl `catchIO` \_ -> return ())
    462      where
    463       getDirectory f = case takeDirectory f of "" -> "."; d -> d
    464   --
     617runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
     618runGHCi paths maybe_exprs = do
     619  dflags <- getDynFlags
     620  let
     621   read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
    465622
    466623  setGHCContextFromGHCiState
    467624
    468   when (read_dot_files) $ do
    469     mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
    470     mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
    471     mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
    472         -- nub, because we don't want to read .ghci twice if the
    473         -- CWD is $HOME.
     625  -- The current dir dot file is not automatically trusted unless the
     626  -- current dir is the app user dir or home dir or the current dir dot
     627  -- file is also passed as a script argument.
     628  when (read_dot_files) $
     629    readDotFiles (not (isJust maybe_exprs)) (ghciScripts dflags)
    474630
    475631  -- Perform a :load for files given on the GHCi command line
    476632  -- When in -e mode, if the load fails then we want to stop