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, 2 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