hackage-repo-tool 0.1.0.1 → 0.1.1
raw patch · 11 files changed
+549/−494 lines, 11 filesdep ~Cabaldep ~directorydep ~hackage-security
Dependency ranges changed: Cabal, directory, hackage-security, optparse-applicative, tar, time
Files
- ChangeLog.md +4/−0
- hackage-repo-tool.cabal +14/−6
- src/Hackage/Security/RepoTool/Layout.hs +89/−0
- src/Hackage/Security/RepoTool/Layout/Keys.hs +44/−0
- src/Hackage/Security/RepoTool/Options.hs +198/−0
- src/Hackage/Security/RepoTool/Paths.hs +33/−0
- src/Hackage/Security/RepoTool/Util/IO.hs +112/−0
- src/Hackage/Security/Utility/Layout.hs +0/−148
- src/Hackage/Security/Utility/Options.hs +0/−173
- src/Hackage/Security/Utility/Util/IO.hs +0/−112
- src/Main.hs +55/−55
ChangeLog.md view
@@ -1,3 +1,7 @@+0.1.1+-----+* Update for hackage-security-0.5+ 0.1.0.1 ------- * Add missing module to other-modules (#100)
hackage-repo-tool.cabal view
@@ -1,5 +1,5 @@ name: hackage-repo-tool-version: 0.1.0.1+version: 0.1.1 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@@ -14,33 +14,41 @@ maintainer: edsko@well-typed.com copyright: Copyright 2015 Well-Typed LLP category: Distribution+homepage: https://github.com/well-typed/hackage-security+bug-reports: https://github.com/well-typed/hackage-security/issues build-type: Simple cabal-version: >=1.10 extra-source-files: ChangeLog.md +source-repository head+ type: git+ location: https://github.com/well-typed/hackage-security.git+ 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- Hackage.Security.Utility.Util.IO+ other-modules: Hackage.Security.RepoTool.Options+ Hackage.Security.RepoTool.Layout+ Hackage.Security.RepoTool.Layout.Keys+ Hackage.Security.RepoTool.Paths+ Hackage.Security.RepoTool.Util.IO 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,+ optparse-applicative >= 0.11 && < 0.13, 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.4+ hackage-security >= 0.5 && < 0.6 hs-source-dirs: src default-language: Haskell2010 default-extensions: DeriveDataTypeable
+ src/Hackage/Security/RepoTool/Layout.hs view
@@ -0,0 +1,89 @@+-- | 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.RepoTool.Layout (+ -- * Additional paths in the repository+ repoLayoutIndexDir+ -- * 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.RepoTool.Layout.Keys+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Paths++{-------------------------------------------------------------------------------+ 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 $ fragment "index"++{-------------------------------------------------------------------------------+ 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' :: GlobalOpts -> TargetPath' -> String+prettyTargetPath' opts = pretty . applyTargetPath' opts++-- | Apply the layout+applyTargetPath' :: GlobalOpts -> TargetPath' -> TargetPath+applyTargetPath' GlobalOpts{..} targetPath =+ case targetPath of+ InRep file -> TargetPathRepo $ file globalRepoLayout+ InIdx file -> TargetPathIndex $ file globalIndexLayout+ InRepPkg file pkgId -> TargetPathRepo $ file globalRepoLayout pkgId+ InIdxPkg file pkgId -> TargetPathIndex $ file globalIndexLayout pkgId++{-------------------------------------------------------------------------------+ Utility+-------------------------------------------------------------------------------}++-- | Anchor a tarball path to the repo (see 'repoLayoutIndex')+anchorIndexPath :: GlobalOpts -> RepoLoc -> (IndexLayout -> IndexPath) -> Path Absolute+anchorIndexPath opts@GlobalOpts{..} repoLoc file =+ anchorRepoPath opts repoLoc repoLayoutIndexDir+ </> unrootPath (file globalIndexLayout)++anchorRepoPath :: GlobalOpts -> RepoLoc -> (RepoLayout -> RepoPath) -> Path Absolute+anchorRepoPath GlobalOpts{..} (RepoLoc repoLoc) file =+ anchorRepoPathLocally repoLoc $ file globalRepoLayout++anchorKeyPath :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> Path Absolute+anchorKeyPath GlobalOpts{..} (KeysLoc keysLoc) dir =+ keysLoc </> unrootPath (dir globalKeysLayout)++anchorTargetPath' :: GlobalOpts -> RepoLoc -> TargetPath' -> Path Absolute+anchorTargetPath' opts repoLoc = go+ where+ go :: TargetPath' -> Path Absolute+ go (InRep file) = anchorRepoPath opts repoLoc file+ go (InIdx file) = anchorIndexPath opts repoLoc file+ go (InRepPkg file pkgId) = anchorRepoPath opts repoLoc (`file` pkgId)+ go (InIdxPkg file pkgId) = anchorIndexPath opts repoLoc (`file` pkgId)
+ src/Hackage/Security/RepoTool/Layout/Keys.hs view
@@ -0,0 +1,44 @@+-- | Layout of the directory containing the (private) keys+module Hackage.Security.RepoTool.Layout.Keys (+ -- * Layout of the keys directory+ KeysLayout(..)+ , defaultKeysLayout+ , keysLayoutKey+ ) where++import Hackage.Security.Client+import Hackage.Security.Util.Path+import Hackage.Security.Util.Some++import Hackage.Security.RepoTool.Paths++-- | 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 -> Path Unrooted+ }++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 :: Path Unrooted -> KeyPath+ rp = rootPath++keysLayoutKey :: (KeysLayout -> KeyPath) -> Some Key -> KeysLayout -> KeyPath+keysLayoutKey dir key keysLayout@KeysLayout{..} =+ dir keysLayout </> keysLayoutKeyFile key
+ src/Hackage/Security/RepoTool/Options.hs view
@@ -0,0 +1,198 @@+module Hackage.Security.RepoTool.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.RepoTool.Layout.Keys+import Hackage.Security.RepoTool.Paths++{-------------------------------------------------------------------------------+ Types+-------------------------------------------------------------------------------}++-- | Command line options+data GlobalOpts = GlobalOpts {+ -- | Key directory layout+ globalKeysLayout :: KeysLayout++ -- | Local repository layout+ , globalRepoLayout :: RepoLayout++ -- | Local index layout+ , globalIndexLayout :: IndexLayout++ -- | Should we be verbose?+ , globalVerbose :: Bool++ -- | Expiry time when creating root (in years)+ , globalExpireRoot :: Integer++ -- | Expiry time when creating mirrors (in years)+ , globalExpireMirrors :: Integer++ -- | 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 (Path Absolute)++ -- | Create mirrors metadata+ | CreateMirrors KeysLoc (Path Absolute) [URI]++ -- | Create a directory with symlinks in cabal-local-rep layout+ | SymlinkCabalLocalRepo RepoLoc RepoLoc++ -- | Sign an individual file+ | Sign [KeyLoc] DeleteExistingSignatures (Path Absolute)++type KeyLoc = Path Absolute+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)+ <*> (pure hackageIndexLayout)+ <*> (switch $ mconcat [+ long "verbose"+ , short 'v'+ , help "Verbose logging"+ ])+ <*> (option auto $ mconcat [+ long "expire-root"+ , metavar "YEARS"+ , help "Expiry time for the root info"+ , value 1+ , showDefault+ ])+ <*> (option auto $ mconcat [+ long "expire-mirrors"+ , metavar "YEARS"+ , help "Expiry time for the mirrors"+ , value 10+ , showDefault+ ])+ <*> (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 (Path Absolute)+readAbsolutePath = return . unsafePerformIO . makeAbsolute . fromFilePath
+ src/Hackage/Security/RepoTool/Paths.hs view
@@ -0,0 +1,33 @@+-- | Additional paths+module Hackage.Security.RepoTool.Paths (+ -- * Repo+ RepoLoc(..)+ -- * Keys+ , KeyRoot+ , KeyPath+ , KeysLoc(..)+ ) where++import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty++{-------------------------------------------------------------------------------+ Repo+-------------------------------------------------------------------------------}++newtype RepoLoc = RepoLoc { repoLocPath :: Path Absolute }+ deriving Eq++{-------------------------------------------------------------------------------+ Keys+-------------------------------------------------------------------------------}++-- | The key directory+data KeyRoot+type KeyPath = Path KeyRoot++instance Pretty (Path KeyRoot) where+ pretty (Path fp) = "<keys>/" ++ fp++newtype KeysLoc = KeysLoc { keysLocPath :: Path Absolute }+ deriving Eq
+ src/Hackage/Security/RepoTool/Util/IO.hs view
@@ -0,0 +1,112 @@+-- | IO utilities+{-# LANGUAGE CPP #-}+module Hackage.Security.RepoTool.Util.IO (+ -- * Miscellaneous+ compress+ , getFileModTime+ , createSymbolicLink+ -- * Tar archives+ , TarGzError+ , tarExtractFile+ ) where++import Control.Exception+import Data.Typeable+import System.IO.Error+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString.Lazy as BS.L++-- Unlike the hackage-security library properly,+-- this currently works on unix systems only+import System.Posix.Types (EpochTime)+import qualified System.Posix.Files as Posix++-- hackage-security+import Hackage.Security.Util.Path++-- hackage-repo-tool+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Layout+import Hackage.Security.RepoTool.Paths++-- | Get the modification time of the specified file+--+-- Returns 0 if the file does not exist .+getFileModTime :: GlobalOpts -> RepoLoc -> TargetPath' -> IO EpochTime+getFileModTime opts repoLoc targetPath =+ handle handler $+ Posix.modificationTime <$> Posix.getFileStatus (toFilePath fp)+ where+ fp :: Path Absolute+ fp = anchorTargetPath' opts repoLoc targetPath++ handler :: IOException -> IO EpochTime+ handler ex = if isDoesNotExistError ex then return 0+ else throwIO ex++compress :: Path Absolute -> Path Absolute -> IO ()+compress src dst =+ withFile dst WriteMode $ \h ->+ BS.L.hPut h =<< GZip.compress <$> readLazyByteString src++-- | Create a symbolic link (unix only)+--+-- Create the directory for the target if it does not exist.+--+-- TODO: Currently this always creates links to absolute locations, whether the+-- user specified an absolute or a relative target.+createSymbolicLink :: (FsRoot root, FsRoot root')+ => Path root -- ^ Link target+ -> Path root' -- ^ Link location+ -> IO ()+createSymbolicLink linkTarget linkLoc = do+ createDirectoryIfMissing True (takeDirectory linkLoc)+ linkTarget' <- toAbsoluteFilePath linkTarget+ linkLoc' <- toAbsoluteFilePath linkLoc+ Posix.createSymbolicLink linkTarget' linkLoc'++{-------------------------------------------------------------------------------+ Working with tar archives+-------------------------------------------------------------------------------}++-- | Extract a file from a tar archive+--+-- Throws an exception if there is an error in the archive or when the entry+-- is not a file. Returns nothing if the entry cannot be found.+tarExtractFile :: GlobalOpts+ -> RepoLoc+ -> TargetPath'+ -> FilePath+ -> IO (Maybe (BS.L.ByteString, Tar.FileSize))+tarExtractFile opts repoLoc pathTarGz pathToExtract =+ handle (throwIO . TarGzError (prettyTargetPath' opts pathTarGz)) $ do+ let pathTarGz' = anchorTargetPath' opts repoLoc pathTarGz+ go =<< Tar.read . GZip.decompress <$> readLazyByteString pathTarGz'+ where+ go :: Exception e => Tar.Entries e -> IO (Maybe (BS.L.ByteString, Tar.FileSize))+ go Tar.Done = return Nothing+ go (Tar.Fail err) = throwIO err+ go (Tar.Next e es) =+ if Tar.entryPath e == pathToExtract+ then case Tar.entryContent e of+ Tar.NormalFile bs sz -> return $ Just (bs, sz)+ _ -> throwIO $ userError+ $ "tarExtractFile: "+ ++ pathToExtract ++ " not a normal file"+ else do -- putStrLn $ show (Tar.entryPath e) ++ " /= " ++ show path+ go es++data TarGzError = TarGzError FilePath SomeException+ deriving (Typeable)++instance Exception TarGzError where+#if MIN_VERSION_base(4,8,0)+ displayException (TarGzError path e) = path ++ ": " ++ displayException e++deriving instance Show TarGzError+#else+instance Show TarGzError where+ show (TarGzError path e) = path ++ ": " ++ show e+#endif
− src/Hackage/Security/Utility/Layout.hs
@@ -1,148 +0,0 @@--- | 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
@@ -1,173 +0,0 @@-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/Hackage/Security/Utility/Util/IO.hs
@@ -1,112 +0,0 @@--- | IO utilities-{-# LANGUAGE CPP #-}-module Hackage.Security.Utility.Util.IO (- -- * Miscellaneous- compress- , getFileModTime- , createSymbolicLink- -- * Tar archives- , TarGzError- , tarExtractFile- ) where--import Control.Exception-import Data.Typeable-import System.IO.Error-import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Compression.GZip as GZip-import qualified Data.ByteString.Lazy as BS.L---- Unlike the hackage-security library properly,--- this currently works on unix systems only-import System.Posix.Types (EpochTime)-import qualified System.Posix.Files as Posix---- hackage-security-import Hackage.Security.Util.IO-import Hackage.Security.Util.Path---- hackage-security-utility-import Hackage.Security.Utility.Options-import Hackage.Security.Utility.Layout---- | Get the modification time of the specified file------ Returns 0 if the file does not exist .-getFileModTime :: GlobalOpts -> RepoLoc -> TargetPath' -> IO EpochTime-getFileModTime GlobalOpts{..} repoLoc targetPath =- handle handler $- Posix.modificationTime <$> Posix.getFileStatus (toFilePath fp)- where- fp :: AbsolutePath- fp = anchorTargetPath' globalRepoLayout repoLoc targetPath-- handler :: IOException -> IO EpochTime- handler ex = if isDoesNotExistError ex then return 0- else throwIO ex--compress :: AbsolutePath -> AbsolutePath -> IO ()-compress src dst =- atomicWithFile dst $ \h ->- BS.L.hPut h =<< GZip.compress <$> readLazyByteString src---- | Create a symbolic link (unix only)------ Create the directory for the target if it does not exist.------ TODO: Currently this always creates links to absolute locations, whether the--- user specified an absolute or a relative target.-createSymbolicLink :: (IsFileSystemRoot root, IsFileSystemRoot root')- => Path (Rooted root) -- ^ Link target- -> Path (Rooted root') -- ^ Link location- -> IO ()-createSymbolicLink linkTarget linkLoc = do- createDirectoryIfMissing True (takeDirectory linkLoc)- linkTarget' <- toAbsoluteFilePath linkTarget- linkLoc' <- toAbsoluteFilePath linkLoc- Posix.createSymbolicLink linkTarget' linkLoc'--{-------------------------------------------------------------------------------- Working with tar archives--------------------------------------------------------------------------------}---- | Extract a file from a tar archive------ Throws an exception if there is an error in the archive or when the entry--- is not a file. Returns nothing if the entry cannot be found.-tarExtractFile :: GlobalOpts- -> RepoLoc- -> TargetPath'- -> FilePath- -> IO (Maybe (BS.L.ByteString, Tar.FileSize))-tarExtractFile GlobalOpts{..} repoLoc pathTarGz pathToExtract =- handle (throwIO . TarGzError (prettyTargetPath' globalRepoLayout pathTarGz)) $ do- let pathTarGz' = anchorTargetPath' globalRepoLayout repoLoc pathTarGz- go =<< Tar.read . GZip.decompress <$> readLazyByteString pathTarGz'- where- go :: Exception e => Tar.Entries e -> IO (Maybe (BS.L.ByteString, Tar.FileSize))- go Tar.Done = return Nothing- go (Tar.Fail err) = throwIO err- go (Tar.Next e es) =- if Tar.entryPath e == pathToExtract- then case Tar.entryContent e of- Tar.NormalFile bs sz -> return $ Just (bs, sz)- _ -> throwIO $ userError- $ "tarExtractFile: "- ++ pathToExtract ++ " not a normal file"- else do -- putStrLn $ show (Tar.entryPath e) ++ " /= " ++ show path- go es--data TarGzError = TarGzError FilePath SomeException- deriving (Typeable)--instance Exception TarGzError where-#if MIN_VERSION_base(4,8,0)- displayException (TarGzError path e) = path ++ ": " ++ displayException e--deriving instance Show TarGzError-#else-instance Show TarGzError where- show (TarGzError path e) = path ++ ": " ++ show e-#endif
src/Main.hs view
@@ -26,13 +26,15 @@ 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) +-- hackage-repo-tool+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Layout+import Hackage.Security.RepoTool.Layout.Keys+import Hackage.Security.RepoTool.Paths+import Hackage.Security.RepoTool.Util.IO+ {------------------------------------------------------------------------------- Main application driver -------------------------------------------------------------------------------}@@ -117,7 +119,7 @@ forM_ privateMirrors $ writeKey opts keysLoc keysLayoutMirrors readKeysAt :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> IO [Some Key]-readKeysAt opts@GlobalOpts{..} keysLoc subDir = catMaybes <$> do+readKeysAt opts keysLoc subDir = catMaybes <$> do entries <- getDirectoryContents absPath forM entries $ \entry -> do let path = absPath </> entry@@ -127,7 +129,7 @@ return Nothing Right key -> return $ Just key where- absPath = anchorKeyPath globalKeysLayout keysLoc subDir+ absPath = anchorKeyPath opts keysLoc subDir writeKey :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> Some Key -> IO () writeKey opts@GlobalOpts{..} keysLoc subDir key = do@@ -136,7 +138,7 @@ writeJSON_NoLayout absPath key where relPath = keysLayoutKey subDir key- absPath = anchorKeyPath globalKeysLayout keysLoc relPath+ absPath = anchorKeyPath opts keysLoc relPath {------------------------------------------------------------------------------- Creating individual files@@ -144,7 +146,7 @@ We translate absolute paths to repo layout to fit with rest of infrastructure. -------------------------------------------------------------------------------} -createRoot :: GlobalOpts -> KeysLoc -> AbsolutePath -> IO ()+createRoot :: GlobalOpts -> KeysLoc -> Path Absolute -> IO () createRoot opts@GlobalOpts{..} keysLoc rootLoc = do keys <- readKeys opts keysLoc now <- getCurrentTime@@ -159,7 +161,7 @@ repoLayoutRoot = rootFragment $ takeFileName rootLoc } -createMirrors :: GlobalOpts -> KeysLoc -> AbsolutePath -> [URI] -> IO ()+createMirrors :: GlobalOpts -> KeysLoc -> Path Absolute -> [URI] -> IO () createMirrors opts@GlobalOpts{..} keysLoc mirrorsLoc mirrors = do keys <- readKeys opts keysLoc now <- getCurrentTime@@ -175,8 +177,8 @@ repoLayoutMirrors = rootFragment $ takeFileName mirrorsLoc } -rootFragment :: Fragment -> RepoPath-rootFragment = rootPath Rooted . fragment+rootFragment :: String -> RepoPath+rootFragment = rootPath . fragment {------------------------------------------------------------------------------- Bootstrapping / updating@@ -230,13 +232,13 @@ ++ " file(s) to " ++ prettyRepo repoLayoutIndexTar unless (null newFiles) $ do tarAppend- (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTar)- (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexDir)+ (anchorRepoPath opts repoLoc repoLayoutIndexTar)+ (anchorRepoPath opts repoLoc repoLayoutIndexDir) (map castRoot newFiles) logInfo opts $ "Writing " ++ prettyRepo repoLayoutIndexTarGz- compress (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTar)- (anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTarGz)+ compress (anchorRepoPath opts repoLoc repoLayoutIndexTar)+ (anchorRepoPath opts repoLoc repoLayoutIndexTarGz) -- Create snapshot -- TODO: If we are updating we should be incrementing the version, not@@ -274,15 +276,15 @@ (withSignatures globalRepoLayout (privateTimestamp keys)) timestamp where- pathIndexTar :: AbsolutePath- pathIndexTar = anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexTar+ pathIndexTar :: Path Absolute+ pathIndexTar = anchorRepoPath opts repoLoc repoLayoutIndexTar -- | Compute file information for a file in the repo computeFileInfo' :: (RepoLayout -> RepoPath) -> IO FileInfo- computeFileInfo' = computeFileInfo . anchorRepoPath globalRepoLayout repoLoc+ computeFileInfo' = computeFileInfo . anchorRepoPath opts repoLoc prettyRepo :: (RepoLayout -> RepoPath) -> String- prettyRepo = prettyTargetPath' globalRepoLayout . InRep+ prettyRepo = prettyTargetPath' opts . InRep -- | Create root metadata updateRoot :: GlobalOpts@@ -302,7 +304,7 @@ root :: Root root = Root { rootVersion = versionInitial- , rootExpires = expiresInDays now 365+ , rootExpires = expiresInDays now (globalExpireRoot opts * 365) , rootKeys = KeyEnv.fromKeys $ concat [ privateRoot keys , privateTarget keys@@ -353,7 +355,7 @@ mirrors :: Mirrors mirrors = Mirrors { mirrorsVersion = versionInitial- , mirrorsExpires = expiresInDays now (10 * 365)+ , mirrorsExpires = expiresInDays now (globalExpireMirrors opts * 365) , mirrorsMirrors = map mkMirror uris } @@ -362,7 +364,7 @@ -- | Create package metadata createPackageMetadata :: GlobalOpts -> RepoLoc -> WhenWrite -> PackageIdentifier -> IO ()-createPackageMetadata opts@GlobalOpts{..} repoLoc whenWrite pkgId = do+createPackageMetadata opts repoLoc whenWrite pkgId = do srcTS <- getFileModTime opts repoLoc src dstTS <- getFileModTime opts repoLoc dst let skip = case whenWrite of@@ -370,7 +372,7 @@ WriteUpdate -> dstTS >= srcTS if skip- then logInfo opts $ "Skipping " ++ prettyTargetPath' globalRepoLayout dst+ then logInfo opts $ "Skipping " ++ prettyTargetPath' opts dst else do fileMapEntries <- mapM computeFileMapEntry fileMapFiles let targets = Targets {@@ -390,8 +392,8 @@ where computeFileMapEntry :: TargetPath' -> IO (TargetPath, FileInfo) computeFileMapEntry file = do- info <- computeFileInfo $ anchorTargetPath' globalRepoLayout repoLoc file- return (applyTargetPath' globalRepoLayout file, info)+ info <- computeFileInfo $ anchorTargetPath' opts repoLoc file+ return (applyTargetPath' opts file, info) -- The files we need to add to the package targets file -- Currently this is just the .tar.gz file@@ -413,7 +415,7 @@ indexFiles <- getRecursiveContents absIndexDir let indexFiles' :: [IndexPath]- indexFiles' = map (rootPath Rooted) indexFiles+ indexFiles' = map rootPath indexFiles case whenWrite of WriteInitial -> return indexFiles'@@ -423,8 +425,8 @@ if fileTS > indexTS then return $ Just indexFile else return Nothing where- absIndexDir :: AbsolutePath- absIndexDir = anchorRepoPath globalRepoLayout repoLoc repoLayoutIndexDir+ absIndexDir :: Path Absolute+ absIndexDir = anchorRepoPath opts repoLoc repoLayoutIndexDir -- | Extract the cabal file from the package tarball and copy it to the index extractCabalFile :: GlobalOpts -> RepoLoc -> WhenWrite -> PackageIdentifier -> IO ()@@ -435,7 +437,7 @@ WriteInitial -> False WriteUpdate -> dstTS >= srcTS if skip- then logInfo opts $ "Skipping " ++ prettyTargetPath' globalRepoLayout dst+ then logInfo opts $ "Skipping " ++ prettyTargetPath' opts dst else do mCabalFile <- try $ tarExtractFile opts repoLoc src pathCabalInTar case mCabalFile of@@ -446,11 +448,11 @@ logWarn opts $ ".cabal file missing for package " ++ display pkgId Right (Just (cabalFile, _cabalSize)) -> do logInfo opts $ "Writing "- ++ prettyTargetPath' globalRepoLayout dst+ ++ prettyTargetPath' opts dst ++ " (extracted from "- ++ prettyTargetPath' globalRepoLayout src+ ++ prettyTargetPath' opts src ++ ")"- atomicWithFile pathCabalInIdx $ \h -> BS.L.hPut h cabalFile+ withFile pathCabalInIdx WriteMode $ \h -> BS.L.hPut h cabalFile where pathCabalInTar :: FilePath pathCabalInTar = FilePath.joinPath [@@ -458,8 +460,8 @@ , display (packageName pkgId) ] FilePath.<.> "cabal" - pathCabalInIdx :: AbsolutePath- pathCabalInIdx = anchorTargetPath' globalRepoLayout repoLoc dst+ pathCabalInIdx :: Path Absolute+ pathCabalInIdx = anchorTargetPath' opts repoLoc dst src, dst :: TargetPath' dst = InIdxPkg indexLayoutPkgCabal pkgId@@ -535,7 +537,7 @@ wOldFileInfo = fileInfo wOldRendered if knownFileInfoEqual oldFileInfo wOldFileInfo- then logInfo opts $ "Unchanged " ++ prettyTargetPath' globalRepoLayout fileLoc+ then logInfo opts $ "Unchanged " ++ prettyTargetPath' opts fileLoc else writeDoc updating wIncVersion where -- | Actually write the file@@ -545,14 +547,14 @@ createDirectoryIfMissing True (takeDirectory fp) writeJSON globalRepoLayout fp (signPayload doc) - fp :: AbsolutePath- fp = anchorTargetPath' globalRepoLayout repoLoc fileLoc+ fp :: Path Absolute+ fp = anchorTargetPath' opts 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+ writing = "Writing " ++ prettyTargetPath' opts fileLoc+ creating = "Creating " ++ prettyTargetPath' opts fileLoc+ overwriting = "Overwriting " ++ prettyTargetPath' opts fileLoc ++ " (old file corrupted)"+ updating = "Updating " ++ prettyTargetPath' opts fileLoc {------------------------------------------------------------------------------- Inspect the repo layout@@ -569,26 +571,26 @@ findPackages GlobalOpts{..} (RepoLoc repoLoc) = nub . mapMaybe isPackage <$> getRecursiveContents repoLoc where- isPackage :: UnrootedPath -> Maybe PackageIdentifier+ isPackage :: Path Unrooted -> Maybe PackageIdentifier isPackage path = do guard $ not (isIndex path) pkg <- hasExtensions path [".tar", ".gz"] simpleParse pkg - isIndex :: UnrootedPath -> Bool- isIndex = (==) (unrootPath' (repoLayoutIndexTarGz globalRepoLayout))+ isIndex :: Path Unrooted -> 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+checkRepoLayout opts repoLoc = liftM and . mapM checkPackage where checkPackage :: PackageIdentifier -> IO Bool checkPackage pkgId = do- existsTarGz <- doesFileExist $ anchorTargetPath' globalRepoLayout repoLoc expectedTarGz+ existsTarGz <- doesFileExist $ anchorTargetPath' opts repoLoc expectedTarGz unless existsTarGz $ logWarn opts $ "Package tarball " ++ display pkgId ++ " expected in location "- ++ prettyTargetPath' globalRepoLayout expectedTarGz+ ++ prettyTargetPath' opts expectedTarGz return existsTarGz where@@ -616,14 +618,15 @@ ++ " (already exists)" else throwIO ex where- target = anchorRepoPath globalRepoLayout repoLoc file- loc = anchorRepoPath cabalLocalRepoLayout cabalRepoLoc file+ target = anchorRepoPath opts repoLoc file+ loc = anchorRepoPath opts' cabalRepoLoc file+ opts' = opts { globalRepoLayout = cabalLocalRepoLayout } {------------------------------------------------------------------------------- Signing individual files -------------------------------------------------------------------------------} -signFile :: [KeyLoc] -> DeleteExistingSignatures -> AbsolutePath -> IO ()+signFile :: [KeyLoc] -> DeleteExistingSignatures -> Path Absolute -> IO () signFile keyLocs deleteExisting fp = do UninterpretedSignatures (payload :: JSValue) oldSigs <- throwErrors =<< readJSON_NoKeys_NoLayout fp@@ -657,16 +660,13 @@ -- -- > hasExtensions "foo.tar.gz" [".tar", ".gz"] == Just "foo" hasExtensions :: Path a -> [String] -> Maybe String-hasExtensions = \fp exts -> go (takeFileName' fp) (reverse exts)+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