diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hackage-repo-tool.cabal b/hackage-repo-tool.cabal new file mode 100644 --- /dev/null +++ b/hackage-repo-tool.cabal @@ -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 diff --git a/src/Hackage/Security/Utility/Layout.hs b/src/Hackage/Security/Utility/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Utility/Layout.hs @@ -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 _ = "" + +-- | 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) diff --git a/src/Hackage/Security/Utility/Options.hs b/src/Hackage/Security/Utility/Options.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Utility/Options.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -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