Merge commit '9886ce5854b487f1968fbc8def9060ba2a477f6c' of https://gi…

…thub.com/edsko/hackage-server into edsko-using-hackage-security

Conflicts:
	hackage-server.cabal

.gitignore

@@ -7,5 +7,3 @@ tags
 .cabal-sandbox
 cabal.sandbox.config
 TAGS
-datafiles/TUF/*.json
-datafiles/TUF/*.private

Distribution/Client/Mirror/Repo.hs

@@ -161,11 +161,19 @@ uploadPackage :: TargetRepo
               -> FilePath
               -> FilePath
               -> MirrorSession ()
-uploadPackage TargetHackage2{..} doMirrorUploaders =
-    Hackage2.uploadPackage targetRepoURI doMirrorUploaders
-uploadPackage TargetLocal{..} _doMirrorUploaders =
-    -- _doMirrorUploaders only relevant for smart repos
-    Local.uploadPackage targetRepoPath
+uploadPackage targetRepo doMirrorUploaders pkgInfo locCab locTgz =
+     case targetRepo of
+       TargetHackage2{..} ->
+         Hackage2.uploadPackage targetRepoURI
+                                doMirrorUploaders
+                                pkgInfo
+                                locCab
+                                locTgz
+       TargetLocal{..} ->
+         -- doMirrorUploaders and locCab not relevant for local repo
+         Local.uploadPackage targetRepoPath
+                             pkgInfo
+                             locTgz
 
 {-------------------------------------------------------------------------------
   Finalizing

Distribution/Client/Mirror/Repo/Local.hs

@@ -11,7 +11,6 @@ import System.Directory
 import System.FilePath
 
 -- Cabal
-import Distribution.Package
 import Distribution.Text
 
 -- hackage
@@ -55,19 +54,12 @@ downloadIndex root _cacheDir = do
 uploadPackage :: FilePath
               -> PkgIndexInfo
               -> FilePath
-              -> FilePath
               -> MirrorSession ()
-uploadPackage targetRepoPath pkginfo locCab locTgz = liftIO $ do
+uploadPackage targetRepoPath pkginfo locTgz = liftIO $ do
     createDirectoryIfMissing True pkgDir
-    createDirectoryIfMissing True cabalDir
     copyFile locTgz pkgFile
-    copyFile locCab cabalFile
   where
-    pkgDir    = targetRepoPath </> "package"
-    cabalDir  = targetRepoPath </> "index"
-                               </> display (packageName pkgid)
-                               </> display (packageVersion pkgid)
-    pkgFile   = pkgDir   </> display pkgid <.> "tar.gz"
-    cabalFile = cabalDir </> display (packageName pkgid) <.> "cabal"
+    pkgDir  = targetRepoPath </> "package"
+    pkgFile = pkgDir   </> display pkgid <.> "tar.gz"
 
     PkgIndexInfo pkgid _ _ _ = pkginfo

Distribution/Client/Mirror/Repo/Secure.hs

@@ -13,13 +13,13 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Cont
-import Data.Maybe (fromJust, fromMaybe)
+import Data.Maybe (fromMaybe)
+import Data.Time (getCurrentTime)
 import Network.URI (URI)
 import System.Directory
 import System.FilePath
 import System.IO
-import qualified Data.ByteString as BS
-import qualified Data.ByteString as BS.L
+import qualified Data.ByteString.Lazy as BS.L
 
 -- Cabal
 import Distribution.Package
@@ -33,11 +33,11 @@ import Distribution.Client.Mirror.Repo.Types
 
 -- hackage-security
 import qualified Hackage.Security.Client                    as Sec
-import qualified Hackage.Security.Client.Repository.Cache   as Sec
+import qualified Hackage.Security.Client.Repository.Cache   as Sec.Cache
 import qualified Hackage.Security.Client.Repository.HttpLib as Sec
 import qualified Hackage.Security.Client.Repository.Remote  as Sec.Remote
 import qualified Hackage.Security.Util.Checked              as Sec
-import qualified Hackage.Security.Util.Path                 as Sec.Path
+import qualified Hackage.Security.Util.Path                 as Sec
 import qualified Hackage.Security.Util.Pretty               as Sec
 
 withSourceRepo :: Verbosity
@@ -48,32 +48,29 @@ withSourceRepo :: Verbosity
                -> Maybe [Sec.KeyId]
                -> (SourceRepo -> IO a) -> IO a
 withSourceRepo verbosity httpLib uri cacheDir threshold keys callback = do
-    cacheDir' <- Sec.Path.makeAbsolute (Sec.Path.fromFilePath cacheDir)
+    cacheDir' <- Sec.makeAbsolute (Sec.fromFilePath cacheDir)
 
     -- It is important that we get the compressed index _as it exists_
     -- on the server because we cannot reliably recreate it (with the same
     -- hash) from the uncompressed index. Therefore we record in the cache
     -- layout where we want the compressed index to be stored, and we tell
     -- the repository that it should always download the compressed index.
 
-    let rp :: Sec.Path.UnrootedPath -> Sec.CachePath
-        rp = Sec.Path.rootPath Sec.Path.Rooted
+    let rp :: Sec.Path Sec.Unrooted -> Sec.CachePath
+        rp = Sec.rootPath
 
-        cache :: Sec.Cache
-        cache = Sec.Cache {
-            Sec.cacheRoot   = cacheDir'
-          , Sec.cacheLayout = Sec.cabalCacheLayout {
-                Sec.cacheLayoutIndexTarGz =
-                  Just $ rp $ Sec.Path.fragment' "00-index.tar.gz"
+        cache :: Sec.Cache.Cache
+        cache = Sec.Cache.Cache {
+            Sec.Cache.cacheRoot   = cacheDir'
+          , Sec.Cache.cacheLayout = Sec.cabalCacheLayout {
+                Sec.cacheLayoutIndexTarGz = rp $ Sec.fragment "00-index.tar.gz"
               }
           }
 
-        repoOptions :: Sec.Remote.RepoOpts
-        repoOptions = Sec.Remote.RepoOpts
-           { repoAllowContentCompression = True
-           , repoWantCompressedIndex = True
-           , repoAllowAdditionalMirrors = True
-           }
+        repoOpts :: Sec.Remote.RepoOpts
+        repoOpts = Sec.Remote.defaultRepoOpts {
+            Sec.Remote.repoAllowAdditionalMirrors = False
+          }
 
         logger :: Sec.LogMessage -> IO ()
         logger msg = when (verbosity >= verbose) $
@@ -82,9 +79,10 @@ withSourceRepo verbosity httpLib uri cacheDir threshold keys callback = do
     Sec.Remote.withRepository
       httpLib
       [uri]
-      repoOptions
+      repoOpts
       cache
       Sec.hackageRepoLayout
+      Sec.hackageIndexLayout
       logger $ \rep ->
         callback SourceSecure {
             sourceRepository    = rep
@@ -93,28 +91,29 @@ withSourceRepo verbosity httpLib uri cacheDir threshold keys callback = do
           , sourceRepoThreshold = fromMaybe (Sec.KeyThreshold 0) threshold
           }
 
-downloadIndex :: Sec.Repository
-              -> Sec.Cache
+downloadIndex :: Sec.Repository down
+              -> Sec.Cache.Cache
               -> [Sec.KeyId]
               -> Sec.KeyThreshold
               -> MirrorSession [PkgIndexInfo]
-downloadIndex rep Sec.Cache{..} rootKeys threshold =
+downloadIndex rep Sec.Cache.Cache{..} rootKeys threshold =
     handleChecked (mirrorError . verificationError) $
     handleChecked (mirrorError . remoteError)       $ do
       _hasUpdates <- liftIO $ do
         requiresBootstrap <- Sec.requiresBootstrap rep
         when requiresBootstrap $ Sec.bootstrap rep rootKeys threshold
-        Sec.checkForUpdates rep Sec.CheckExpiry
+        now <- getCurrentTime
+        Sec.checkForUpdates rep (Just now)
       -- TODO: Is this hasUpdates values useful anywhere?
       readIndex (show rep) indexPath
   where
     verificationError = GetEntityError EntityIndex . GetVerificationError
     remoteError       = GetEntityError EntityIndex . GetRemoteError
 
-    indexPath = Sec.Path.toFilePath $
+    indexPath = Sec.toFilePath $
       Sec.anchorCachePath cacheRoot (Sec.cacheLayoutIndexTar cacheLayout)
 
-downloadPackage :: Sec.Repository
+downloadPackage :: Sec.Repository down
                 -> PackageId
                 -> FilePath
                 -> FilePath
@@ -124,9 +123,10 @@ downloadPackage rep pkgId locCab locTgz =
    handleChecked (return . Just . GetVerificationError) $
    handleChecked (return . Just . GetRemoteError)       $
      liftIO $ do
-       Sec.downloadPackage rep pkgId $ \tempPath ->
-         renameFile (Sec.Path.toFilePath tempPath) locTgz
-       BS.writeFile locCab =<< Sec.getCabalFile rep pkgId
+       Sec.downloadPackage' rep pkgId locTgz
+       cabalFile <- Sec.withIndex rep $ \Sec.IndexCallbacks{..} ->
+         Sec.trusted `liftM` indexLookupCabal pkgId
+       BS.L.writeFile locCab cabalFile
        return Nothing
 
 -- | Finalize the mirror (copy over index and TUF files)
@@ -161,29 +161,30 @@ downloadPackage rep pkgId locCab locTgz =
 -- start versioning files on the server as described in the TUF spec; however,
 -- since this is only applies to a few files, and clients will simply retry when
 -- they get a verification error, it's not a priority.
-finalizeLocalMirror :: Sec.Cache -> FilePath -> MirrorSession ()
+finalizeLocalMirror :: Sec.Cache.Cache -> FilePath -> MirrorSession ()
 finalizeLocalMirror cache targetRepoPath = liftIO $ do
-    repoRoot <- Sec.Path.makeAbsolute $ Sec.Path.fromFilePath targetRepoPath
+    repoRoot <- Sec.makeAbsolute $ Sec.fromFilePath targetRepoPath
     finalizeLocalMirror' cache repoRoot
 
-finalizeLocalMirror' :: Sec.Cache -> Sec.Path.AbsolutePath -> IO ()
+finalizeLocalMirror' :: Sec.Cache.Cache -> Sec.Path Sec.Absolute -> IO ()
 finalizeLocalMirror' cache repoRoot = (`runContT` return) $ do
     -- TODO: We need to think about updating these files atomically
-    cp Sec.cacheLayoutIndexTar                Sec.repoLayoutIndexTar
-    cp (fromJust . Sec.cacheLayoutIndexTarGz) Sec.repoLayoutIndexTarGz
-    cp Sec.cacheLayoutMirrors                 Sec.repoLayoutMirrors
-    cp Sec.cacheLayoutRoot                    Sec.repoLayoutRoot
-    cp Sec.cacheLayoutSnapshot                Sec.repoLayoutSnapshot
-    cp Sec.cacheLayoutTimestamp               Sec.repoLayoutTimestamp
+    cp Sec.cacheLayoutIndexTar   Sec.repoLayoutIndexTar
+    cp Sec.cacheLayoutIndexTarGz Sec.repoLayoutIndexTarGz
+    cp Sec.cacheLayoutMirrors    Sec.repoLayoutMirrors
+    cp Sec.cacheLayoutRoot       Sec.repoLayoutRoot
+    cp Sec.cacheLayoutSnapshot   Sec.repoLayoutSnapshot
+    cp Sec.cacheLayoutTimestamp  Sec.repoLayoutTimestamp
   where
     cp :: (Sec.CacheLayout -> Sec.CachePath)
        -> (Sec.RepoLayout  -> Sec.RepoPath)
        -> ContT r IO ()
     cp src dst = copyFileAtomic (cacheFP cache src) (repoFP repoRoot dst)
 
     copyFileAtomic :: FilePath -> FilePath -> ContT r IO ()
-    copyFileAtomic src dst = ContT $ \callback ->
-      bracket (openTempFile (takeDirectory dst) (takeFileName dst))
+    copyFileAtomic src dst = ContT $ \callback -> do
+      let (dir, template) = splitFileName dst
+      bracket (openBinaryTempFileWithDefaultPermissions dir template)
               (\(temp, h) -> ignoreIOErrors (hClose h >> removeFile temp)) $
               (\(temp, h) -> do
                  BS.L.hPut h =<< BS.L.readFile src
@@ -195,22 +196,22 @@ finalizeLocalMirror' cache repoRoot = (`runContT` return) $ do
     ignoreIOErrors :: IO () -> IO ()
     ignoreIOErrors = handle $ \(_ :: IOException) -> return ()
 
-cacheTargetIndex :: Sec.Cache -> FilePath -> MirrorSession ()
+cacheTargetIndex :: Sec.Cache.Cache -> FilePath -> MirrorSession ()
 cacheTargetIndex cache targetCache = liftIO $
-     copyFile (cacheFP cache $ fromJust . Sec.cacheLayoutIndexTarGz)
+     copyFile (cacheFP cache Sec.cacheLayoutIndexTarGz)
               (targetCachedIndexPath targetCache)
 
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}
 
-cacheFP :: Sec.Cache -> (Sec.CacheLayout -> Sec.CachePath) -> FilePath
-cacheFP Sec.Cache{..} f = Sec.Path.toFilePath
-                        $ Sec.anchorCachePath cacheRoot
-                        $ f cacheLayout
+cacheFP :: Sec.Cache.Cache -> (Sec.CacheLayout -> Sec.CachePath) -> FilePath
+cacheFP Sec.Cache.Cache{..} f = Sec.toFilePath
+                              $ Sec.anchorCachePath cacheRoot
+                              $ f cacheLayout
 
-repoFP :: Sec.Path.AbsolutePath -> (Sec.RepoLayout -> Sec.RepoPath) -> FilePath
-repoFP repoRoot f = Sec.Path.toFilePath
+repoFP :: Sec.Path Sec.Absolute -> (Sec.RepoLayout -> Sec.RepoPath) -> FilePath
+repoFP repoRoot f = Sec.toFilePath
                   $ Sec.anchorRepoPathLocally repoRoot
                   $ f Sec.hackageRepoLayout
 
@@ -219,5 +220,5 @@ handleChecked :: Exception e
               -> (Sec.Throws e => MirrorSession a)
               -> MirrorSession a
 handleChecked handler act = do
-    run <- askRun
-    liftCont (Sec.catchChecked (run act)) handler
+    run <- askUnlift
+    liftCont (Sec.catchChecked (unlift run act)) handler

Distribution/Client/Mirror/Repo/Types.hs

@@ -24,8 +24,8 @@ data SourceRepo =
       }
 
     -- | Secure repo
-  | SourceSecure {
-        sourceRepository    :: Sec.Repository
+  | forall down. SourceSecure {
+        sourceRepository    :: Sec.Repository down
       , sourceRepoCache     :: Sec.Cache
       , sourceRepoRootKeys  :: [Sec.KeyId]
       , sourceRepoThreshold :: Sec.KeyThreshold

Distribution/Client/Mirror/Session.hs

@@ -4,14 +4,17 @@
 -- lists for imports of Distribution.Client in the Mirror.* modules.)
 {-# LANGUAGE DeriveDataTypeable  #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes          #-}
 module Distribution.Client.Mirror.Session (
     -- * MirrorSession
     MirrorSession -- Opaque
   , runMirrorSession
   , mirrorError
   , mirrorAskHttpLib
   , liftCont
-  , askRun
+  , Unlift(..)
+  , askUnlift
+  , mirrorFinally
     -- * Errors
   , MirrorError(..)
   , Entity(..)
@@ -190,10 +193,12 @@ runMirrorSession verbosity keepGoing st (MirrorSession m) = do
 mirrorError :: MirrorError -> MirrorSession a
 mirrorError = liftIO . throwIO
 
+newtype Unlift = Unlift { unlift :: forall a. MirrorSession a -> IO a }
+
 -- | Unlifting from MirrorSession to IO (@monad-unlift@ style)
-askRun :: MirrorSession (MirrorSession a -> IO a)
-askRun = MirrorSession $ ReaderT $ \env ->
-    return $ \act -> runReaderT (unMirror act) env
+askUnlift :: MirrorSession Unlift
+askUnlift = MirrorSession $ ReaderT $ \env ->
+    return $ Unlift $ \act -> runReaderT (unMirror act) env
 
 -- | Lift a continuation in IO to a continuation in MirrorSession
 --
@@ -204,7 +209,14 @@ askRun = MirrorSession $ ReaderT $ \env ->
 -- > liftCont :: ContT r IO a -> ContT r MirrorSession a
 liftCont :: ((a -> IO            b) -> IO            b)
          -> ((a -> MirrorSession b) -> MirrorSession b)
-liftCont f g = askRun >>= \run -> liftIO $ f $ \a -> run (g a)
+liftCont f g = do
+    run <- askUnlift
+    liftIO $ f $ \a -> unlift run (g a)
+
+mirrorFinally :: MirrorSession a -> MirrorSession b -> MirrorSession a
+mirrorFinally a b = do
+    run <- askUnlift
+    liftIO $ unlift run a `finally` unlift run b
 
 mirrorAskHttpLib :: MirrorSession Sec.HttpLib
 mirrorAskHttpLib = MirrorSession $ do

Distribution/Server/Features/Core/Backup.hs

@@ -20,6 +20,7 @@ import Distribution.Server.Framework.BackupRestore
 import Distribution.Server.Framework.BackupDump
 import Distribution.Server.Framework.BlobStorage (BlobId, blobMd5)
 import Distribution.Server.Users.Types (UserName(..))
+import Distribution.Server.Features.Security.SHA256
 import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 
 import Distribution.Package
@@ -44,8 +45,6 @@ import qualified Data.ByteString.Lazy as BS
 import qualified Data.ByteString.Lazy.Char8 as BSC
 import System.FilePath ((</>))
 
-import qualified Data.Digest.Pure.SHA as SHA
-
 packagesBackup :: RestoreBackup PackagesState
 packagesBackup = updatePackages (PartialIndex Map.empty Nothing)
 
@@ -72,7 +71,7 @@ data PartialPkg = PartialPkg {
 data TarballInfo = TarballInfo {
     infoTarGzMD5    :: BlobId
   , infoTarGzLength :: Int
-  , infoTarGzSHA256 :: SHA.Digest SHA.SHA256State
+  , infoTarGzSHA256 :: SHA256Digest
   , infoTarMD5      :: BlobId
   }
 

Distribution/Server/Features/Security.hs

@@ -132,7 +132,8 @@ securityFeature env securityState securityFileCache securityCache =
       , resourceGet  = [("json", serveFromCache securityCacheMirrors )]
       }
 
-    serveFromCache :: (SecurityCache -> TUFFile a)
+    serveFromCache :: (IsTUFFile a, ToMessage a)
+                   => (SecurityCache -> a)
                    -> DynamicPath
                    -> ServerPartE Response
     serveFromCache file _ = do
@@ -167,7 +168,7 @@ securityStateComponent env stateDir = do
       , restoreState = securityRestore timestampKey snapshotKey
       }
   where
-    readKey :: Sec.AbsolutePath -> IO (Some Sec.Key)
+    readKey :: Sec.Path Sec.Absolute -> IO (Some Sec.Key)
     readKey fp = do
       mKey <- Sec.readJSON_NoKeys_NoLayout fp
       case mKey of