hackage-repo-tool (empty) → 0.1.0.0
raw patch · 7 files changed
+1110/−0 lines, 7 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, directory, filepath, hackage-security, network, network-uri, optparse-applicative, tar, time, unix, zlib
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hackage-repo-tool.cabal +57/−0
- src/Hackage/Security/Utility/Layout.hs +148/−0
- src/Hackage/Security/Utility/Options.hs +173/−0
- src/Main.hs +673/−0
- src/Prelude.hs +27/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Well-Typed LLP nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-repo-tool.cabal view
@@ -0,0 +1,57 @@+name: hackage-repo-tool+version: 0.1.0.0+synopsis: Utility to manage secure file-based package repositories+description: This utility can be used to manage secure file-based+ repositories (creating TUF metadata as well as a Hackage+ index tarball). Currently it also provides various+ lower level utilities for creating and signing TUF files.+ .+ This is part of the Hackage Security infrastructure.+homepage: http://github.com/well-typed/hackage-security/+license: BSD3+license-file: LICENSE+author: Edsko de Vries+maintainer: edsko@well-typed.com+copyright: Copyright 2015 Well-Typed LLP+category: Distribution+build-type: Simple+cabal-version: >=1.10++flag use-network-uri+ description: Are we using network-uri?+ manual: False++executable hackage-repo-tool+ main-is: Main.hs+ other-modules: Hackage.Security.Utility.Options+ Hackage.Security.Utility.Layout+ Prelude+ build-depends: base >= 4.4 && < 5,+ Cabal >= 1.12 && < 1.25,+ bytestring >= 0.9 && < 0.11,+ directory >= 1.1 && < 1.3,+ filepath >= 1.2 && < 1.5,+ optparse-applicative >= 0.11 && < 0.12,+ tar >= 0.4 && < 0.5,+ time >= 1.2 && < 1.6,+ unix >= 2.5 && < 2.8,+ zlib >= 0.5 && < 0.7,+ hackage-security >= 0.2 && < 0.3+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: DeriveDataTypeable+ FlexibleContexts+ FlexibleInstances+ NoMonomorphismRestriction+ ScopedTypeVariables+ StandaloneDeriving+ RecordWildCards+ other-extensions: TemplateHaskell+ ghc-options: -Wall++ -- see comments in hackage-security.cabal+ if flag(use-network-uri)+ build-depends: network-uri >= 2.6 && < 2.7,+ network >= 2.6 && < 2.7+ else+ build-depends: network >= 2.5 && < 2.6
+ src/Hackage/Security/Utility/Layout.hs view
@@ -0,0 +1,148 @@+-- | Layout of the local repository as managed by this tool+--+-- The local repository follows a RepoLayout exactly, but adds some additional+-- files. In addition, we also manage a directory of keys (although this will+-- eventually need to be replaced with a proper key management system).+module Hackage.Security.Utility.Layout (+ -- * File system locations+ RepoLoc(..)+ , KeysLoc(..)+ -- * Additional paths in the repository+ , repoLayoutIndexDir+ -- * Layout of the keys directory+ , KeyRoot+ , KeyPath+ , KeysLayout(..)+ , defaultKeysLayout+ , keysLayoutKey+ -- * Layout-parametrized version of TargetPath+ , TargetPath'(..)+ , prettyTargetPath'+ , applyTargetPath'+ -- * Utility+ , anchorIndexPath+ , anchorRepoPath+ , anchorKeyPath+ , anchorTargetPath'+ ) where++import Distribution.Package++import Hackage.Security.Client+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some++{-------------------------------------------------------------------------------+ File system locations+-------------------------------------------------------------------------------}++newtype RepoLoc = RepoLoc { repoLocPath :: AbsolutePath }+ deriving Eq++newtype KeysLoc = KeysLoc { keysLocPath :: AbsolutePath }+ deriving Eq++{-------------------------------------------------------------------------------+ Additional paths specifically to the kind of repository this tool manages+-------------------------------------------------------------------------------}++-- | Directory containing the unpacked index+--+-- Since the layout of the tarball may not match the layout of the index,+-- we create a local directory with the unpacked contents of the index.+repoLayoutIndexDir :: RepoLayout -> RepoPath+repoLayoutIndexDir _ = rootPath Rooted $ fragment' "index"++{-------------------------------------------------------------------------------+ Key layout+-------------------------------------------------------------------------------}++-- | The key directory+data KeyRoot+type KeyPath = Path (Rooted KeyRoot)++instance IsRoot KeyRoot where showRoot _ = "<keys>"++-- | Layout of the keys directory+--+-- Specifies the directories containing the keys (relative to the keys loc),+-- as well as the filename for individual keys.+data KeysLayout = KeysLayout {+ keysLayoutRoot :: KeyPath+ , keysLayoutTarget :: KeyPath+ , keysLayoutTimestamp :: KeyPath+ , keysLayoutSnapshot :: KeyPath+ , keysLayoutMirrors :: KeyPath+ , keysLayoutKeyFile :: Some Key -> UnrootedPath+ }++defaultKeysLayout :: KeysLayout+defaultKeysLayout = KeysLayout {+ keysLayoutRoot = rp $ fragment' "root"+ , keysLayoutTarget = rp $ fragment' "target"+ , keysLayoutTimestamp = rp $ fragment' "timestamp"+ , keysLayoutSnapshot = rp $ fragment' "snapshot"+ , keysLayoutMirrors = rp $ fragment' "mirrors"+ , keysLayoutKeyFile = \key -> let kId = keyIdString (someKeyId key)+ in fragment' kId <.> "private"+ }+ where+ rp :: UnrootedPath -> KeyPath+ rp = rootPath Rooted++keysLayoutKey :: (KeysLayout -> KeyPath) -> Some Key -> KeysLayout -> KeyPath+keysLayoutKey dir key keysLayout@KeysLayout{..} =+ dir keysLayout </> keysLayoutKeyFile key++{-------------------------------------------------------------------------------+ TargetPath'+-------------------------------------------------------------------------------}++-- | This is a variation on 'TargetPath' parameterized by layout+data TargetPath' =+ InRep (RepoLayout -> RepoPath)+ | InIdx (IndexLayout -> IndexPath)+ | InRepPkg (RepoLayout -> PackageIdentifier -> RepoPath) PackageIdentifier+ | InIdxPkg (IndexLayout -> PackageIdentifier -> IndexPath) PackageIdentifier++prettyTargetPath' :: RepoLayout -> TargetPath' -> String+prettyTargetPath' repoLayout = pretty . applyTargetPath' repoLayout++-- | Apply the layout+applyTargetPath' :: RepoLayout -> TargetPath' -> TargetPath+applyTargetPath' repoLayout targetPath =+ case targetPath of+ InRep file -> TargetPathRepo $ file repoLayout+ InIdx file -> TargetPathIndex $ file indexLayout+ InRepPkg file pkgId -> TargetPathRepo $ file repoLayout pkgId+ InIdxPkg file pkgId -> TargetPathIndex $ file indexLayout pkgId+ where+ indexLayout = repoIndexLayout repoLayout++{-------------------------------------------------------------------------------+ Utility+-------------------------------------------------------------------------------}++-- | Anchor a tarball path to the repo (see 'repoLayoutIndex')+anchorIndexPath :: RepoLayout -> RepoLoc -> (IndexLayout -> IndexPath) -> AbsolutePath+anchorIndexPath repoLayout repoLoc file =+ anchorRepoPath repoLayout repoLoc repoLayoutIndexDir+ </> unrootPath' (file $ repoIndexLayout repoLayout)++anchorRepoPath :: RepoLayout -> RepoLoc -> (RepoLayout -> RepoPath) -> AbsolutePath+anchorRepoPath repoLayout (RepoLoc repoLoc) file =+ anchorRepoPathLocally repoLoc $ file repoLayout++anchorKeyPath :: KeysLayout -> KeysLoc -> (KeysLayout -> KeyPath) -> AbsolutePath+anchorKeyPath keysLayout (KeysLoc keysLoc) dir =+ keysLoc </> unrootPath' (dir keysLayout)++anchorTargetPath' :: RepoLayout -> RepoLoc -> TargetPath' -> AbsolutePath+anchorTargetPath' repoLayout repoLoc = go+ where+ go :: TargetPath' -> AbsolutePath+ go (InRep file) = anchorRepoPath repoLayout repoLoc file+ go (InIdx file) = anchorIndexPath repoLayout repoLoc file+ go (InRepPkg file pkgId) = anchorRepoPath repoLayout repoLoc (`file` pkgId)+ go (InIdxPkg file pkgId) = anchorIndexPath repoLayout repoLoc (`file` pkgId)
+ src/Hackage/Security/Utility/Options.hs view
@@ -0,0 +1,173 @@+module Hackage.Security.Utility.Options (+ GlobalOpts(..)+ , Command(..)+ , KeyLoc+ , DeleteExistingSignatures+ , getOptions+ ) where++import Network.URI (URI, parseURI)+import Options.Applicative+import System.IO.Unsafe (unsafePerformIO)++import Hackage.Security.Client+import Hackage.Security.Util.Path++import Hackage.Security.Utility.Layout++{-------------------------------------------------------------------------------+ Types+-------------------------------------------------------------------------------}++-- | Command line options+data GlobalOpts = GlobalOpts {+ -- | Key directory layout+ globalKeysLayout :: KeysLayout++ -- | Local repository layout+ , globalRepoLayout :: RepoLayout++ -- | Should we be verbose?+ , globalVerbose :: Bool++ -- | Command to execute+ , globalCommand :: Command+ }++data Command =+ -- | Create keys+ CreateKeys KeysLoc++ -- | Bootstrap a secure local repository+ | Bootstrap KeysLoc RepoLoc++ -- | Update a previously bootstrapped local repository+ | Update KeysLoc RepoLoc++ -- | Create root metadta+ | CreateRoot KeysLoc AbsolutePath++ -- | Create mirrors metadata+ | CreateMirrors KeysLoc AbsolutePath [URI]++ -- | Create a directory with symlinks in cabal-local-rep layout+ | SymlinkCabalLocalRepo RepoLoc RepoLoc++ -- | Sign an individual file+ | Sign [KeyLoc] DeleteExistingSignatures AbsolutePath++type KeyLoc = AbsolutePath+type DeleteExistingSignatures = Bool++{-------------------------------------------------------------------------------+ Parsers+-------------------------------------------------------------------------------}++getOptions :: IO GlobalOpts+getOptions = execParser opts+ where+ opts = info (helper <*> parseGlobalOptions) $ mconcat [+ fullDesc+ , header "Manage local Hackage repositories"+ ]++parseRepoLoc :: Parser RepoLoc+parseRepoLoc = RepoLoc <$> (option (str >>= readAbsolutePath) $ mconcat [+ long "repo"+ , metavar "PATH"+ , help "Path to local repository"+ ])++parseKeysLoc :: Parser KeysLoc+parseKeysLoc = KeysLoc <$> (option (str >>= readAbsolutePath) $ mconcat [+ long "keys"+ , metavar "PATH"+ , help "Path to key store"+ ])++parseCreateKeys :: Parser Command+parseCreateKeys = CreateKeys <$> parseKeysLoc++parseBootstrap :: Parser Command+parseBootstrap = Bootstrap <$> parseKeysLoc <*> parseRepoLoc++parseUpdate :: Parser Command+parseUpdate = Update <$> parseKeysLoc <*> parseRepoLoc++parseCreateRoot :: Parser Command+parseCreateRoot = CreateRoot+ <$> parseKeysLoc+ <*> (option (str >>= readAbsolutePath) $ mconcat [+ short 'o'+ , metavar "FILE"+ , help "Location of the root file"+ ])++parseCreateMirrors :: Parser Command+parseCreateMirrors = CreateMirrors+ <$> parseKeysLoc+ <*> (option (str >>= readAbsolutePath) $ mconcat [+ short 'o'+ , metavar "FILE"+ , help "Location of the mirrors file"+ ])+ <*> (many $ argument (str >>= readURI) (metavar "MIRROR"))++parseSymlinkCabalLocalRepo :: Parser Command+parseSymlinkCabalLocalRepo = SymlinkCabalLocalRepo+ <$> parseRepoLoc+ <*> (option (str >>= liftA RepoLoc . readAbsolutePath) $ mconcat [+ long "cabal-repo"+ , help "Location of the cabal repo"+ ])++parseSign :: Parser Command+parseSign = Sign+ <$> (many . option (str >>= readAbsolutePath) $ mconcat [+ long "key"+ , help "Path to private key (can be specified multiple times)"+ ])+ <*> (switch $ mconcat [+ long "delete-existing"+ , help "Delete any existing signatures"+ ])+ <*> argument (str >>= readAbsolutePath) (metavar "FILE")++-- | Global options+--+-- TODO: Make repo and keys layout configurable+parseGlobalOptions :: Parser GlobalOpts+parseGlobalOptions = GlobalOpts+ <$> (pure defaultKeysLayout)+ <*> (pure hackageRepoLayout)+ <*> (switch $ mconcat [+ long "verbose"+ , short 'v'+ , help "Verbose logging"+ ])+ <*> (subparser $ mconcat [+ command "create-keys" $ info (helper <*> parseCreateKeys) $+ progDesc "Create keys"+ , command "bootstrap" $ info (helper <*> parseBootstrap) $+ progDesc "Bootstrap a local repository"+ , command "update" $ info (helper <*> parseUpdate) $+ progDesc "Update a (previously bootstrapped) local repository"+ , command "create-root" $ info (helper <*> parseCreateRoot) $+ progDesc "Create root metadata"+ , command "create-mirrors" $ info (helper <*> parseCreateMirrors) $+ progDesc "Create mirrors metadata. All MIRRORs specified on the command line will be written to the file."+ , command "symlink-cabal-local-repo" $ info (helper <*> parseSymlinkCabalLocalRepo) $+ progDesc "Create a directory in cabal-local-repo layout with symlinks to the specified repository."+ , command "sign" $ info (helper <*> parseSign) $+ progDesc "Sign a file"+ ])++readURI :: String -> ReadM URI+readURI uriStr =+ case parseURI uriStr of+ Nothing -> fail $ "Invalid URI " ++ show uriStr+ Just uri -> return uri++-- Sadly, cannot do I/O actions inside ReadM+readAbsolutePath :: String -> ReadM AbsolutePath+readAbsolutePath = return . unsafePerformIO . makeAbsolute . fromFilePath
+ src/Main.hs view
@@ -0,0 +1,673 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Control.Exception+import Control.Monad+import Data.List (nub)+import Data.Maybe (catMaybes, mapMaybe)+import Data.Time+import GHC.Conc.Sync (setUncaughtExceptionHandler)+import Network.URI (URI)+import System.Exit+import System.IO.Error (isAlreadyExistsError)+import qualified Data.ByteString.Lazy as BS.L+import qualified System.FilePath as FilePath++-- Cabal+import Distribution.Package+import Distribution.Text++-- hackage-security+import Hackage.Security.Server+import Hackage.Security.Util.Some+import Hackage.Security.Util.IO+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Key.Env as KeyEnv+import qualified Hackage.Security.TUF.FileMap as FileMap+import qualified Hackage.Security.Util.Lens as Lens++-- hackage-security-utility+import Hackage.Security.Utility.Options+import Hackage.Security.Utility.Layout+import Hackage.Security.Utility.Util.IO+import Text.JSON.Canonical (JSValue)++{-------------------------------------------------------------------------------+ Main application driver+-------------------------------------------------------------------------------}++main :: IO ()+main = do+ setUncaughtExceptionHandler topLevelExceptionHandler+ opts@GlobalOpts{..} <- getOptions+ case globalCommand of+ CreateKeys keysLoc ->+ createKeys opts keysLoc+ Bootstrap keysLoc repoLoc ->+ bootstrapOrUpdate opts keysLoc repoLoc True+ Update keysLoc repoLoc ->+ bootstrapOrUpdate opts keysLoc repoLoc False+ CreateRoot keysLoc rootLoc ->+ createRoot opts keysLoc rootLoc+ CreateMirrors keysLoc mirrorsLoc mirrors ->+ createMirrors opts keysLoc mirrorsLoc mirrors+ SymlinkCabalLocalRepo repoLoc cabalRepoLoc ->+ symlinkCabalLocalRepo opts repoLoc cabalRepoLoc+ Sign keys deleteExisting file ->+ signFile keys deleteExisting file++-- | Top-level exception handler that uses 'displayException'+--+-- Although base 4.8 introduces 'displayException', the top-level exception+-- handler still uses 'show', sadly. See "PROPOSAL: Add displayException to+-- Exception typeclass" thread on the libraries mailing list.+--+-- NOTE: This is a terrible hack. See the above thread for some insights into+-- how we should do this better. For now it will do however.+topLevelExceptionHandler :: SomeException -> IO ()+topLevelExceptionHandler e = do+ putStrLn $ displayException e+ exitFailure++#if !MIN_VERSION_base(4,8,0)+displayException :: Exception e => e -> String+displayException = show+#endif++{-------------------------------------------------------------------------------+ Creating keys+-------------------------------------------------------------------------------}++createKeys :: GlobalOpts -> KeysLoc -> IO ()+createKeys opts keysLoc = do+ privateRoot <- replicateM 3 $ createKey' KeyTypeEd25519+ privateTarget <- replicateM 3 $ createKey' KeyTypeEd25519+ privateTimestamp <- replicateM 1 $ createKey' KeyTypeEd25519+ privateSnapshot <- replicateM 1 $ createKey' KeyTypeEd25519+ privateMirrors <- replicateM 3 $ createKey' KeyTypeEd25519+ writeKeys opts keysLoc PrivateKeys{..}++{-------------------------------------------------------------------------------+ Dealing with (private) keys+-------------------------------------------------------------------------------}++data PrivateKeys = PrivateKeys {+ privateRoot :: [Some Key]+ , privateTarget :: [Some Key]+ , privateTimestamp :: [Some Key]+ , privateSnapshot :: [Some Key]+ , privateMirrors :: [Some Key]+ }++readKeys :: GlobalOpts -> KeysLoc -> IO PrivateKeys+readKeys opts keysLoc =+ PrivateKeys <$> readKeysAt opts keysLoc keysLayoutRoot+ <*> readKeysAt opts keysLoc keysLayoutTarget+ <*> readKeysAt opts keysLoc keysLayoutTimestamp+ <*> readKeysAt opts keysLoc keysLayoutSnapshot+ <*> readKeysAt opts keysLoc keysLayoutMirrors++writeKeys :: GlobalOpts -> KeysLoc -> PrivateKeys -> IO ()+writeKeys opts keysLoc PrivateKeys{..} = do+ forM_ privateRoot $ writeKey opts keysLoc keysLayoutRoot+ forM_ privateTarget $ writeKey opts keysLoc keysLayoutTarget+ forM_ privateTimestamp $ writeKey opts keysLoc keysLayoutTimestamp+ forM_ privateSnapshot $ writeKey opts keysLoc keysLayoutSnapshot+ forM_ privateMirrors $ writeKey opts keysLoc keysLayoutMirrors++readKeysAt :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> IO [Some Key]+readKeysAt opts@GlobalOpts{..} keysLoc subDir = catMaybes <$> do+ entries <- getDirectoryContents absPath+ forM entries $ \entry -> do+ let path = absPath </> entry+ mKey <- readJSON_NoKeys_NoLayout path+ case mKey of+ Left _err -> do logWarn opts $ "Skipping unrecognized " ++ pretty path+ return Nothing+ Right key -> return $ Just key+ where+ absPath = anchorKeyPath globalKeysLayout keysLoc subDir++writeKey :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> Some Key -> IO ()+writeKey opts@GlobalOpts{..} keysLoc subDir key = do+ logInfo opts $ "Writing " ++ pretty (relPath globalKeysLayout)+ createDirectoryIfMissing True (takeDirectory absPath)+ writeJSON_NoLayout absPath key+ where+ relPath = keysLayoutKey subDir key+ absPath = anchorKeyPath globalKeysLayout keysLoc relPath++{-------------------------------------------------------------------------------+ Creating individual files++ We translate absolute paths to repo layout to fit with rest of infrastructure.+-------------------------------------------------------------------------------}++createRoot :: GlobalOpts -> KeysLoc -> AbsolutePath -> IO ()+createRoot opts@GlobalOpts{..} keysLoc rootLoc = do+ keys <- readKeys opts keysLoc+ now <- getCurrentTime+ updateRoot opts { globalRepoLayout = layout }+ repoLoc+ WriteUpdate+ keys+ now+ where+ repoLoc = RepoLoc $ takeDirectory rootLoc+ layout = globalRepoLayout {+ repoLayoutRoot = rootFragment $ takeFileName rootLoc+ }++createMirrors :: GlobalOpts -> KeysLoc -> AbsolutePath -> [URI] -> IO ()+createMirrors opts@GlobalOpts{..} keysLoc mirrorsLoc mirrors = do+ keys <- readKeys opts keysLoc+ now <- getCurrentTime+ updateMirrors opts { globalRepoLayout = layout }+ repoLoc+ WriteUpdate+ keys+ now+ mirrors+ where+ repoLoc = RepoLoc $ takeDirectory mirrorsLoc+ layout = globalRepoLayout {+ repoLayoutMirrors = rootFragment $ takeFileName mirrorsLoc+ }++rootFragment :: Fragment -> RepoPath+rootFragment = rootPath Rooted . fragment++{-------------------------------------------------------------------------------+ Bootstrapping / updating++ TODO: Some of this functionality should be moved to+ @Hackage.Security.Server.*@ (to be shared by both, say, Hackage, and+ secure-local), but I'm not sure precisely in what form yet.+-------------------------------------------------------------------------------}++bootstrapOrUpdate :: GlobalOpts -> KeysLoc -> RepoLoc -> Bool -> IO ()+bootstrapOrUpdate opts@GlobalOpts{..} keysLoc repoLoc isBootstrap = do+ -- Collect info+ keys <- readKeys opts keysLoc+ now <- getCurrentTime+ pkgs <- findPackages opts repoLoc++ -- Sanity check+ repoLayoutOk <- checkRepoLayout opts repoLoc pkgs+ unless repoLayoutOk $+ throwIO $ userError "Unexpected repository layout"++ -- We overwrite files during bootstrap process, but update them only+ -- if necessary during an update. Note that we _only_ write the updated+ -- files to the tarball, so the user deletes the tarball and then calls+ -- update (rather than bootstrap) the tarball will be missing files.+ let whenWrite = if isBootstrap+ then WriteInitial+ else WriteUpdate++ -- If doing bootstrap: create root and mirrors+ when isBootstrap $ do+ updateRoot opts repoLoc whenWrite keys now+ updateMirrors opts repoLoc whenWrite keys now []++ -- Create targets.json for each package version+ forM_ pkgs $ \pkgId -> do+ createPackageMetadata opts repoLoc whenWrite pkgId+ extractCabalFile opts repoLoc whenWrite pkgId++ -- Recreate index tarball+ newFiles <- findNewIndexFiles opts repoLoc whenWrite+ case (whenWrite, null newFiles) of+ (WriteInitial, _) -> do+ -- If we are recreating all files, also recreate the index+ _didExist <- handleDoesNotExist $ removeFile pathIndexTar+ logInfo opts $ "Writing " ++ prettyRepo repoLayoutIndexTar+ (WriteUpdate, True) -> do+ logInfo opts $ "Skipping " ++ prettyRepo repoLayoutIndexTar+ (WriteUpdate, False) ->+ logInfo opts $ "Appending " ++ show (length newFiles)+ ++ " file(s) to " ++ prettyRepo repoLayoutIndexTar+ unless (null newFiles) $ do+ tarAppend+ (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTar)+ (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexDir)+ (map castRoot newFiles)++ logInfo opts $ "Writing " ++ prettyRepo repoLayoutIndexTarGz+ compress (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTar)+ (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTarGz)++ -- Create snapshot+ -- TODO: If we are updating we should be incrementing the version, not+ -- keeping it the same+ rootInfo <- computeFileInfo' repoLayoutRoot+ mirrorsInfo <- computeFileInfo' repoLayoutMirrors+ tarInfo <- computeFileInfo' repoLayoutIndexTar+ tarGzInfo <- computeFileInfo' repoLayoutIndexTarGz+ let snapshot = Snapshot {+ snapshotVersion = versionInitial+ , snapshotExpires = expiresInDays now 3+ , snapshotInfoRoot = rootInfo+ , snapshotInfoMirrors = mirrorsInfo+ , snapshotInfoTar = Just tarInfo+ , snapshotInfoTarGz = tarGzInfo+ }+ updateFile opts+ repoLoc+ whenWrite+ (InRep repoLayoutSnapshot)+ (withSignatures globalRepoLayout (privateSnapshot keys))+ snapshot++ -- Finally, create the timestamp+ snapshotInfo <- computeFileInfo' repoLayoutSnapshot+ let timestamp = Timestamp {+ timestampVersion = versionInitial+ , timestampExpires = expiresInDays now 3+ , timestampInfoSnapshot = snapshotInfo+ }+ updateFile opts+ repoLoc+ whenWrite+ (InRep repoLayoutTimestamp)+ (withSignatures globalRepoLayout (privateTimestamp keys))+ timestamp+ where+ pathIndexTar :: AbsolutePath+ pathIndexTar = anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTar++ -- | Compute file information for a file in the repo+ computeFileInfo' :: (RepoLayout -> RepoPath) -> IO FileInfo+ computeFileInfo' = computeFileInfo . anchorRepoPath globalRepoLayout repoLoc++ prettyRepo :: (RepoLayout -> RepoPath) -> String+ prettyRepo = prettyTargetPath' globalRepoLayout . InRep++-- | Create root metadata+updateRoot :: GlobalOpts+ -> RepoLoc+ -> WhenWrite+ -> PrivateKeys+ -> UTCTime+ -> IO ()+updateRoot opts repoLoc whenWrite keys now =+ updateFile opts+ repoLoc+ whenWrite+ (InRep repoLayoutRoot)+ (withSignatures' (privateRoot keys))+ root+ where+ root :: Root+ root = Root {+ rootVersion = versionInitial+ , rootExpires = expiresInDays now 365+ , rootKeys = KeyEnv.fromKeys $ concat [+ privateRoot keys+ , privateTarget keys+ , privateSnapshot keys+ , privateTimestamp keys+ , privateMirrors keys+ ]+ , rootRoles = RootRoles {+ rootRolesRoot = RoleSpec {+ roleSpecKeys = map somePublicKey (privateRoot keys)+ , roleSpecThreshold = KeyThreshold 2+ }+ , rootRolesTargets = RoleSpec {+ roleSpecKeys = map somePublicKey (privateTarget keys)+ , roleSpecThreshold = KeyThreshold 1+ }+ , rootRolesSnapshot = RoleSpec {+ roleSpecKeys = map somePublicKey (privateSnapshot keys)+ , roleSpecThreshold = KeyThreshold 1+ }+ , rootRolesTimestamp = RoleSpec {+ roleSpecKeys = map somePublicKey (privateTimestamp keys)+ , roleSpecThreshold = KeyThreshold 1+ }+ , rootRolesMirrors = RoleSpec {+ roleSpecKeys = map somePublicKey (privateMirrors keys)+ , roleSpecThreshold = KeyThreshold 1+ }+ }+ }++-- | Create root metadata+updateMirrors :: GlobalOpts+ -> RepoLoc+ -> WhenWrite+ -> PrivateKeys+ -> UTCTime+ -> [URI]+ -> IO ()+updateMirrors opts repoLoc whenWrite keys now uris =+ updateFile opts+ repoLoc+ whenWrite+ (InRep repoLayoutMirrors)+ (withSignatures' (privateMirrors keys))+ mirrors+ where+ mirrors :: Mirrors+ mirrors = Mirrors {+ mirrorsVersion = versionInitial+ , mirrorsExpires = expiresInDays now (10 * 365)+ , mirrorsMirrors = map mkMirror uris+ }++ mkMirror :: URI -> Mirror+ mkMirror uri = Mirror uri MirrorFull++-- | Create package metadata+createPackageMetadata :: GlobalOpts -> RepoLoc -> WhenWrite -> PackageIdentifier -> IO ()+createPackageMetadata opts@GlobalOpts{..} repoLoc whenWrite pkgId = do+ srcTS <- getFileModTime opts repoLoc src+ dstTS <- getFileModTime opts repoLoc dst+ let skip = case whenWrite of+ WriteInitial -> False+ WriteUpdate -> dstTS >= srcTS++ if skip+ then logInfo opts $ "Skipping " ++ prettyTargetPath' globalRepoLayout dst+ else do+ fileMapEntries <- mapM computeFileMapEntry fileMapFiles+ let targets = Targets {+ targetsVersion = versionInitial+ , targetsExpires = expiresNever+ , targetsTargets = FileMap.fromList fileMapEntries+ , targetsDelegations = Nothing+ }++ -- Currently we "sign" with no keys+ updateFile opts+ repoLoc+ whenWrite+ dst+ (withSignatures' [])+ targets+ where+ computeFileMapEntry :: TargetPath' -> IO (TargetPath, FileInfo)+ computeFileMapEntry file = do+ info <- computeFileInfo $ anchorTargetPath' globalRepoLayout repoLoc file+ return (applyTargetPath' globalRepoLayout file, info)++ -- The files we need to add to the package targets file+ -- Currently this is just the .tar.gz file+ fileMapFiles :: [TargetPath']+ fileMapFiles = [src]++ src, dst :: TargetPath'+ src = InRepPkg repoLayoutPkgTarGz pkgId+ dst = InIdxPkg indexLayoutPkgMetadata pkgId++{-------------------------------------------------------------------------------+ Working with the index+-------------------------------------------------------------------------------}++-- | Find the files we need to add to the index+findNewIndexFiles :: GlobalOpts -> RepoLoc -> WhenWrite -> IO [IndexPath]+findNewIndexFiles opts@GlobalOpts{..} repoLoc whenWrite = do+ indexTS <- getFileModTime opts repoLoc (InRep repoLayoutIndexTar)+ indexFiles <- getRecursiveContents absIndexDir++ let indexFiles' :: [IndexPath]+ indexFiles' = map (rootPath Rooted) indexFiles++ case whenWrite of+ WriteInitial -> return indexFiles'+ WriteUpdate -> liftM catMaybes $+ forM indexFiles' $ \indexFile -> do+ fileTS <- getFileModTime opts repoLoc $ InIdx (const indexFile)+ if fileTS > indexTS then return $ Just indexFile+ else return Nothing+ where+ absIndexDir :: AbsolutePath+ absIndexDir = anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexDir++-- | Extract the cabal file from the package tarball and copy it to the index+extractCabalFile :: GlobalOpts -> RepoLoc -> WhenWrite -> PackageIdentifier -> IO ()+extractCabalFile opts@GlobalOpts{..} repoLoc whenWrite pkgId = do+ srcTS <- getFileModTime opts repoLoc src+ dstTS <- getFileModTime opts repoLoc dst+ let skip = case whenWrite of+ WriteInitial -> False+ WriteUpdate -> dstTS >= srcTS+ if skip+ then logInfo opts $ "Skipping " ++ prettyTargetPath' globalRepoLayout dst+ else do+ mCabalFile <- try $ tarExtractFile opts repoLoc src pathCabalInTar+ case mCabalFile of+ Left (ex :: SomeException) ->+ logWarn opts $ "Failed to extract .cabal from package " ++ display pkgId+ ++ ": " ++ displayException ex+ Right Nothing ->+ logWarn opts $ ".cabal file missing for package " ++ display pkgId+ Right (Just (cabalFile, _cabalSize)) -> do+ logInfo opts $ "Writing "+ ++ prettyTargetPath' globalRepoLayout dst+ ++ " (extracted from "+ ++ prettyTargetPath' globalRepoLayout src+ ++ ")"+ atomicWithFile pathCabalInIdx $ \h -> BS.L.hPut h cabalFile+ where+ pathCabalInTar :: FilePath+ pathCabalInTar = FilePath.joinPath [+ display pkgId+ , display (packageName pkgId)+ ] FilePath.<.> "cabal"++ pathCabalInIdx :: AbsolutePath+ pathCabalInIdx = anchorTargetPath' globalRepoLayout repoLoc dst++ src, dst :: TargetPath'+ dst = InIdxPkg indexLayoutPkgCabal pkgId+ src = InRepPkg repoLayoutPkgTarGz pkgId++{-------------------------------------------------------------------------------+ Updating files in the repo or in the index+-------------------------------------------------------------------------------}++data WhenWrite =+ -- | Write the initial version of a file+ --+ -- If applicable, set file version to 1.+ WriteInitial++ -- | Update an existing+ --+ -- If applicable, increment file version number.+ | WriteUpdate++-- | Write canonical JSON+--+-- We write the file to a temporary location and compare file info with the file+-- that was already in the target location (if any). If it's the same (modulo+-- version number) we don't overwrite it and return Nothing; otherwise we+-- increment the version number, write the file, and (if it's in the index)+-- copy it to the unpacked index directory.+updateFile :: forall a. (ToJSON WriteJSON (Signed a), HasHeader a)+ => GlobalOpts+ -> RepoLoc+ -> WhenWrite+ -> TargetPath'+ -> (a -> Signed a) -- ^ Signing function+ -> a -- ^ Unsigned file contents+ -> IO ()+updateFile opts@GlobalOpts{..} repoLoc whenWrite fileLoc signPayload a = do+ mOldHeader :: Maybe (Either DeserializationError (UninterpretedSignatures Header)) <-+ handleDoesNotExist $ readJSON_NoKeys_NoLayout fp++ case (whenWrite, mOldHeader) of+ (WriteInitial, _) ->+ writeDoc writing a+ (WriteUpdate, Nothing) -> -- no previous version+ writeDoc creating a+ (WriteUpdate, Just (Left _err)) -> -- old file corrupted+ writeDoc overwriting a+ (WriteUpdate, Just (Right (UninterpretedSignatures oldHeader _oldSigs))) -> do+ -- We cannot quite read the entire old file, because we don't know what+ -- key environment to use. Instead, we render the _new_ file, but+ -- setting the version number to be equal to the version number of the+ -- old file. If the result turns out to be equal to the old file (same+ -- FileInfo), we skip writing this file. However, if this is NOT equal,+ -- we set the version number of the new file to be equal to the version+ -- number of the old plus one, and write it.+ oldFileInfo <- computeFileInfo fp++ let oldVersion :: FileVersion+ oldVersion = headerVersion oldHeader++ wOldVersion, wIncVersion :: a+ wOldVersion = Lens.set fileVersion oldVersion a+ wIncVersion = Lens.set fileVersion (versionIncrement oldVersion) a++ wOldSigned :: Signed a+ wOldSigned = signPayload wOldVersion++ wOldRendered :: BS.L.ByteString+ wOldRendered = renderJSON globalRepoLayout wOldSigned++ -- TODO: We could be be more efficient here and verify file size+ -- first; however, these files are tiny so it doesn't really matter.+ wOldFileInfo :: FileInfo+ wOldFileInfo = fileInfo wOldRendered++ if knownFileInfoEqual oldFileInfo wOldFileInfo+ then logInfo opts $ "Unchanged " ++ prettyTargetPath' globalRepoLayout fileLoc+ else writeDoc updating wIncVersion+ where+ -- | Actually write the file+ writeDoc :: String -> a -> IO ()+ writeDoc reason doc = do+ logInfo opts reason+ createDirectoryIfMissing True (takeDirectory fp)+ writeJSON globalRepoLayout fp (signPayload doc)++ fp :: AbsolutePath+ fp = anchorTargetPath' globalRepoLayout repoLoc fileLoc++ writing, creating, overwriting, updating :: String+ writing = "Writing " ++ prettyTargetPath' globalRepoLayout fileLoc+ creating = "Creating " ++ prettyTargetPath' globalRepoLayout fileLoc+ overwriting = "Overwriting " ++ prettyTargetPath' globalRepoLayout fileLoc ++ " (old file corrupted)"+ updating = "Updating " ++ prettyTargetPath' globalRepoLayout fileLoc++{-------------------------------------------------------------------------------+ Inspect the repo layout+-------------------------------------------------------------------------------}++-- | Find packages+--+-- Repository layouts are configurable, but we don't know if the layout of the+-- current directory matches the specified layout. We therefore here just search+-- through the directory looking for anything that looks like a package.+-- We can then verify that this list of packages actually matches the layout as+-- a separate step.+findPackages :: GlobalOpts -> RepoLoc -> IO [PackageIdentifier]+findPackages GlobalOpts{..} (RepoLoc repoLoc) =+ nub . mapMaybe isPackage <$> getRecursiveContents repoLoc+ where+ isPackage :: UnrootedPath -> Maybe PackageIdentifier+ isPackage path = do+ guard $ not (isIndex path)+ pkg <- hasExtensions path [".tar", ".gz"]+ simpleParse pkg++ isIndex :: UnrootedPath -> Bool+ isIndex = (==) (unrootPath' (repoLayoutIndexTarGz globalRepoLayout))++-- | Check that packages are in their expected location+checkRepoLayout :: GlobalOpts -> RepoLoc -> [PackageIdentifier] -> IO Bool+checkRepoLayout opts@GlobalOpts{..} repoLoc = liftM and . mapM checkPackage+ where+ checkPackage :: PackageIdentifier -> IO Bool+ checkPackage pkgId = do+ existsTarGz <- doesFileExist $ anchorTargetPath' globalRepoLayout repoLoc expectedTarGz+ unless existsTarGz $+ logWarn opts $ "Package tarball " ++ display pkgId+ ++ " expected in location "+ ++ prettyTargetPath' globalRepoLayout expectedTarGz++ return existsTarGz+ where+ expectedTarGz :: TargetPath'+ expectedTarGz = InRepPkg repoLayoutPkgTarGz pkgId++{-------------------------------------------------------------------------------+ Creating Cabal-local-repo+-------------------------------------------------------------------------------}++symlinkCabalLocalRepo :: GlobalOpts -> RepoLoc -> RepoLoc -> IO ()+symlinkCabalLocalRepo opts@GlobalOpts{..} repoLoc cabalRepoLoc = do+ symlink repoLayoutIndexTar+ pkgs <- findPackages opts repoLoc+ forM_ pkgs $ \pkgId -> symlink (`repoLayoutPkgTarGz` pkgId)+ where+ -- TODO: This gives a warning for files that we previously linked, as well+ -- as for files that we _never_ need to link (because the location of both+ -- repos is the same). This is potentially confusing.+ symlink :: (RepoLayout -> RepoPath) -> IO ()+ symlink file =+ catch (createSymbolicLink target loc) $ \ex ->+ if isAlreadyExistsError ex+ then logWarn opts $ "Skipping " ++ pretty (file globalRepoLayout)+ ++ " (already exists)"+ else throwIO ex+ where+ target = anchorRepoPath globalRepoLayout repoLoc file+ loc = anchorRepoPath cabalLocalRepoLayout cabalRepoLoc file++{-------------------------------------------------------------------------------+ Signing individual files+-------------------------------------------------------------------------------}++signFile :: [KeyLoc] -> DeleteExistingSignatures -> AbsolutePath -> IO ()+signFile keyLocs deleteExisting fp = do+ UninterpretedSignatures (payload :: JSValue) oldSigs <-+ throwErrors =<< readJSON_NoKeys_NoLayout fp+ keys :: [Some Key] <- forM keyLocs $ \keyLoc ->+ throwErrors =<< readJSON_NoKeys_NoLayout keyLoc+ let newSigs = concat [+ if deleteExisting then [] else oldSigs+ , toPreSignatures (signRendered keys $ renderJSON_NoLayout payload)+ ]+ writeJSON_NoLayout fp $ UninterpretedSignatures payload newSigs++{-------------------------------------------------------------------------------+ Logging+-------------------------------------------------------------------------------}++logInfo :: GlobalOpts -> String -> IO ()+logInfo GlobalOpts{..} str = when globalVerbose $+ putStrLn $ "Info: " ++ str++logWarn :: GlobalOpts -> String -> IO ()+logWarn _opts str =+ putStrLn $ "Warning: " ++ str++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++-- | Check that a file has the given extensions+--+-- Returns the filename without the verified extensions. For example:+--+-- > hasExtensions "foo.tar.gz" [".tar", ".gz"] == Just "foo"+hasExtensions :: Path a -> [String] -> Maybe String+hasExtensions = \fp exts -> go (takeFileName' fp) (reverse exts)+ where+ go :: FilePath -> [String] -> Maybe String+ go fp [] = return fp+ go fp (e:es) = do let (fp', e') = FilePath.splitExtension fp+ guard $ e == e'+ go fp' es++ takeFileName' :: Path a -> String+ takeFileName' = unFragment . takeFileName++throwErrors :: Exception e => Either e a -> IO a+throwErrors (Left err) = throwIO err+throwErrors (Right a) = return a
+ src/Prelude.hs view
@@ -0,0 +1,27 @@+-- | Smooth over differences between various ghc versions by making older+-- preludes look like 4.8.0+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-}+module Prelude (+ module P+#if !MIN_VERSION_base(4,8,0)+ , Applicative(..)+ , Monoid(..)+ , (<$>)+ , (<$)+ , traverse+#endif+ ) where++#if MIN_VERSION_base(4,8,0)+import "base" Prelude as P+#else+#if MIN_VERSION_base(4,6,0)+import "base" Prelude as P+#else+import "base" Prelude as P hiding (catch)+#endif+import Control.Applicative+import Data.Monoid+import Data.Traversable (traverse)+#endif