From fba88af6de6879273975a884a05f2efb52eb6834 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 27 Mar 2019 12:26:32 +0200
Subject: [PATCH] Hackage creds are read-only (fixes #2159)

---
 ChangeLog.md                 |  2 ++
 src/Stack/Upload.hs          | 41 ++++++++++++++++++++++++++++++------
 src/test/Stack/UploadSpec.hs | 28 ++++++++++++++++++++++++
 3 files changed, 65 insertions(+), 6 deletions(-)
 create mode 100644 src/test/Stack/UploadSpec.hs

diff --git a/ChangeLog.md b/ChangeLog.md
index 4060250484..58c971b8a3 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -192,6 +192,8 @@ Bug fixes:
 - Fix detection of aarch64 platform (this broke when we upgraded to a newer Cabal version).
 - Docker: fix detecting and pulling missing images with `--docker-auto-pull`, see
   [#4598](https://github.com/commercialhaskell/stack/issues/4598)
+* Hackage credentials are not world-writable. See
+  [#2159](https://github.com/commercialhaskell/stack/issues/2159).
 
 ## v1.9.3
 
diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs
index db0e5ca25e..fec7cc8614 100644
--- a/src/Stack/Upload.hs
+++ b/src/Stack/Upload.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 -- | Provide ability to upload tarballs to Hackage.
 module Stack.Upload
     ( -- * Upload
@@ -12,14 +13,16 @@ module Stack.Upload
       -- * Credentials
     , HackageCreds
     , loadCreds
+    , writeFilePrivate
     ) where
 
 import           Stack.Prelude
 import           Data.Aeson                            (FromJSON (..),
                                                         ToJSON (..),
-                                                        decode', encode,
+                                                        decode', toEncoding, fromEncoding,
                                                         object, withObject,
                                                         (.:), (.=))
+import           Data.ByteString.Builder               (lazyByteString)
 import qualified Data.ByteString.Char8                 as S
 import qualified Data.ByteString.Lazy                  as L
 import qualified Data.Conduit.Binary                   as CB
@@ -35,9 +38,10 @@ import           Network.HTTP.StackClient              (Request, RequestBody(Req
                                                         displayDigestAuthException)
 import           Stack.Types.Config
 import           System.Directory                      (createDirectoryIfMissing,
-                                                        removeFile)
-import           System.FilePath                       ((</>), takeFileName)
+                                                        removeFile, renameFile)
+import           System.FilePath                       ((</>), takeFileName, takeDirectory)
 import           System.IO                             (stdout, putStrLn, putStr, print) -- TODO remove putStrLn, use logInfo
+import           System.PosixCompat.Files              (setFileMode)
 
 -- | Username and password to log into Hackage.
 --
@@ -67,9 +71,13 @@ loadCreds :: Config -> IO HackageCreds
 loadCreds config = do
   fp <- credsFile config
   elbs <- tryIO $ L.readFile fp
-  case either (const Nothing) Just elbs >>= decode' of
+  case either (const Nothing) Just elbs >>= \lbs -> (lbs, ) <$> decode' lbs of
     Nothing -> fromPrompt fp
-    Just mkCreds -> do
+    Just (lbs, mkCreds) -> do
+      -- Ensure privacy, for cleaning up old versions of Stack that
+      -- didn't do this
+      writeFilePrivate fp $ lazyByteString lbs
+
       unless (configSaveHackageCreds config) $ do
         putStrLn "WARNING: You've set save-hackage-creds to false"
         putStrLn "However, credentials were found at:"
@@ -90,12 +98,33 @@ loadCreds config = do
           "Save hackage credentials to file at " ++ fp ++ " [y/n]? "
         putStrLn "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
         when shouldSave $ do
-          L.writeFile fp (encode hc)
+          writeFilePrivate fp $ fromEncoding $ toEncoding hc
           putStrLn "Saved!"
           hFlush stdout
 
       return hc
 
+-- | Write contents to a file which is always private.
+writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
+writeFilePrivate fp builder = liftIO $ withTempFile (takeDirectory fp) (takeFileName fp) $ \fpTmp h0 -> do
+  -- Close the handle so we can set permissions first
+  hClose h0
+
+  -- Now set the permissions so only we can read and write
+  setFileMode fpTmp 0o600
+
+  -- Now append the contents we want
+  withBinaryFile fpTmp AppendMode $ \h -> hPutBuilder h builder
+
+  -- Disable writing
+  setFileMode fpTmp 0o400
+
+  -- Make sure the destination file, if present, is writeable
+  void $ tryIO $ setFileMode fp 0o600
+
+  -- And atomically move
+  renameFile fpTmp fp
+
 credsFile :: Config -> IO FilePath
 credsFile config = do
     let dir = toFilePath (view stackRootL config) </> "upload"
diff --git a/src/test/Stack/UploadSpec.hs b/src/test/Stack/UploadSpec.hs
new file mode 100644
index 0000000000..f13b12d0d3
--- /dev/null
+++ b/src/test/Stack/UploadSpec.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Stack.UploadSpec (spec) where
+
+import RIO
+import RIO.Directory
+import RIO.FilePath ((</>))
+import Stack.Upload
+import Test.Hspec
+import System.Permissions (osIsWindows)
+import System.PosixCompat.Files (getFileStatus, fileMode)
+import Data.Bits ((.&.))
+
+spec :: Spec
+spec = do
+  it "writeFilePrivate" $ example $ withSystemTempDirectory "writeFilePrivate" $ \dir -> replicateM_ 2 $ do
+    let fp = dir </> "filename"
+        contents :: IsString s => s
+        contents = "These are the contents"
+    writeFilePrivate fp contents
+    actual <- readFileBinary fp
+    actual `shouldBe` contents
+    perms <- getPermissions fp
+    perms `shouldBe` setOwnerReadable True emptyPermissions
+
+    unless osIsWindows $ do
+      status <- getFileStatus fp
+      (fileMode status .&. 0o777) `shouldBe` 0o400