-
Notifications
You must be signed in to change notification settings - Fork 198
/
Secure.hs
224 lines (201 loc) · 9.2 KB
/
Secure.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.Mirror.Repo.Secure (
withSourceRepo
, downloadIndex
, downloadPackage
, finalizeLocalMirror
, cacheTargetIndex
) where
-- stdlib
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Cont
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.Lazy as BS.L
-- Cabal
import Distribution.Package
import Distribution.Verbosity
-- hackage
import Distribution.Client hiding (downloadIndex)
import Distribution.Client.Mirror.Session
import Distribution.Client.Mirror.Repo.Util
import Distribution.Client.Mirror.Repo.Types
-- hackage-security
import qualified Hackage.Security.Client 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
import qualified Hackage.Security.Util.Pretty as Sec
withSourceRepo :: Verbosity
-> Sec.HttpLib
-> URI
-> FilePath
-> Maybe Sec.KeyThreshold
-> Maybe [Sec.KeyId]
-> (SourceRepo -> IO a) -> IO a
withSourceRepo verbosity httpLib uri cacheDir threshold keys callback = do
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 Sec.Unrooted -> Sec.CachePath
rp = Sec.rootPath
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"
}
}
repoOpts :: Sec.Remote.RepoOpts
repoOpts = Sec.Remote.defaultRepoOpts {
Sec.Remote.repoAllowAdditionalMirrors = False
}
logger :: Sec.LogMessage -> IO ()
logger msg = when (verbosity >= verbose) $
putStrLn $ Sec.pretty msg
Sec.Remote.withRepository
httpLib
[uri]
repoOpts
cache
Sec.hackageRepoLayout
Sec.hackageIndexLayout
logger $ \rep ->
callback SourceSecure {
sourceRepository = rep
, sourceRepoCache = cache
, sourceRepoRootKeys = fromMaybe [] keys
, sourceRepoThreshold = fromMaybe (Sec.KeyThreshold 0) threshold
}
downloadIndex :: Sec.Repository down
-> Sec.Cache.Cache
-> [Sec.KeyId]
-> Sec.KeyThreshold
-> MirrorSession [PkgIndexInfo]
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
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.toFilePath $
Sec.anchorCachePath cacheRoot (Sec.cacheLayoutIndexTar cacheLayout)
downloadPackage :: Sec.Repository down
-> PackageId
-> FilePath
-> FilePath
-> MirrorSession (Maybe GetError)
downloadPackage rep pkgId locCab locTgz =
handleChecked (return . Just . GetInvalidPackage) $
handleChecked (return . Just . GetVerificationError) $
handleChecked (return . Just . GetRemoteError) $
liftIO $ do
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)
--
-- We copy everything to temporary files in the destination directory first;
-- only when all files have been successfully copied we move them to their final
-- location. This is especially important if the target directory is mounted on,
-- say, an @sshfs@ file system, where the initial copy can be slow. We want to
-- avoid that these files are out of sync with each other for longer than
-- necessary. (In particular, it is important that these files are never out of
-- sync for longer than it takes a client to cycle through a few
-- check-for-update attempts before giving up.)
--
-- This happens _after_ all packages have been copied over, which poses no
-- problems: as long as the index is not updated, these additional packages are
-- not visible to clients.
--
-- Then we copy over the index before the TUF files; in principle, clients who
-- do an incremental update will not be affected by this (but new clients will
-- be, of course). The relative order of updating the @.tar@ versus the
-- @.tar.gz@ is unimportant: clients will never request both.
--
-- Then we update the TUF files in the opposite order that the client needs
-- them: mirrors, root, snapshot, and timestamp. This minimizes how many clients
-- will see an inconsistent state, although it does not eliminate the problem
-- altogether. (For instance, if we update the snapshot before the timestamp, a
-- client downloading the timestamp will see the old timestamp, conclude there
-- are no chances, and never see the modified snapshot.) However, even if we did
-- (by putting all these files in a directory, say, and symlinking the
-- directory) clients could _still_ see an inconsistent state because they
-- request these files one by one. If we really wanted to fix this, we'd have to
-- 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.Cache -> FilePath -> MirrorSession ()
finalizeLocalMirror cache targetRepoPath = liftIO $ do
repoRoot <- Sec.makeAbsolute $ Sec.fromFilePath targetRepoPath
finalizeLocalMirror' cache repoRoot
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 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 -> 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
hClose h
a <- callback ()
renameFile temp dst
return a)
ignoreIOErrors :: IO () -> IO ()
ignoreIOErrors = handle $ \(_ :: IOException) -> return ()
cacheTargetIndex :: Sec.Cache.Cache -> FilePath -> MirrorSession ()
cacheTargetIndex cache targetCache = liftIO $
copyFile (cacheFP cache Sec.cacheLayoutIndexTarGz)
(targetCachedIndexPath targetCache)
{-------------------------------------------------------------------------------
Auxiliary
-------------------------------------------------------------------------------}
cacheFP :: Sec.Cache.Cache -> (Sec.CacheLayout -> Sec.CachePath) -> FilePath
cacheFP Sec.Cache.Cache{..} f = Sec.toFilePath
$ Sec.anchorCachePath cacheRoot
$ f cacheLayout
repoFP :: Sec.Path Sec.Absolute -> (Sec.RepoLayout -> Sec.RepoPath) -> FilePath
repoFP repoRoot f = Sec.toFilePath
$ Sec.anchorRepoPathLocally repoRoot
$ f Sec.hackageRepoLayout
handleChecked :: Exception e
=> (e -> MirrorSession a)
-> (Sec.Throws e => MirrorSession a)
-> MirrorSession a
handleChecked handler act = do
run <- askUnlift
liftCont (Sec.catchChecked (unlift run act)) handler