hackport 0.5.6 → 0.6
raw patch · 31 files changed
+738/−156 lines, 31 filesnew-uploader
Files
- Merge.hs +8/−4
- Merge/Dependencies.hs +23/−4
- Portage/EBuild.hs +2/−2
- Portage/GHCCore.hs +112/−1
- Portage/Metadata.hs +10/−2
- cabal/Cabal/Distribution/PackageDescription/Configuration.hs +3/−2
- hackage-security/.appveyor.yml +31/−0
- hackage-security/.gitignore +3/−0
- hackage-security/.travis.yml +5/−5
- hackage-security/README.md +1/−1
- hackage-security/example-client/example-client.cabal +1/−1
- hackage-security/hackage-repo-tool/ChangeLog.md +7/−2
- hackage-security/hackage-repo-tool/hackage-repo-tool.cabal +42/−26
- hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Options.hs +7/−0
- hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Util/IO.hs +38/−17
- hackage-security/hackage-repo-tool/src/Main.hs +9/−2
- hackage-security/hackage-root-tool/hackage-root-tool.cabal +1/−1
- hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal +4/−5
- hackage-security/hackage-security-curl/hackage-security-curl.cabal +1/−1
- hackage-security/hackage-security-http-client/hackage-security-http-client.cabal +1/−1
- hackage-security/hackage-security/ChangeLog.md +15/−0
- hackage-security/hackage-security/hackage-security.cabal +32/−22
- hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs +40/−10
- hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs +1/−37
- hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs +39/−2
- hackage-security/hackage-security/src/Hackage/Security/Util/Exit.hs +40/−0
- hackage-security/hackage-security/src/Hackage/Security/Util/FileLock.hsc +202/−0
- hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs +36/−5
- hackage-security/hackage-security/tests/TestSuite.hs +1/−0
- hackage-security/hackage-security/tests/TestSuite/JSON.hs +19/−2
- hackport.cabal +4/−1
Merge.hs view
@@ -383,7 +383,7 @@ Just ucf -> (\e -> e { E.used_options = E.used_options e ++ [("flags", ucf)] })) $ C2E.cabal2ebuild cat pkgDesc - mergeEbuild verbosity existing_meta pkgdir ebuild+ mergeEbuild verbosity existing_meta pkgdir ebuild cabal_flag_descs when fetch $ do let cabal_pkgId = Cabal.packageId pkgDesc norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)@@ -421,14 +421,18 @@ '-':_ -> kw _ -> '~':kw -mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> IO ()-mergeEbuild verbosity existing_meta pkgdir ebuild = do+-- | Generate a list of tuples containing Cabal flag names and descriptions+metaFlags :: [Cabal.Flag] -> [(String, String)]+metaFlags flags = zip (Cabal.unFlagName . Cabal.flagName <$> flags) (Cabal.flagDescription <$> flags)++mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> [Cabal.Flag] -> IO ()+mergeEbuild verbosity existing_meta pkgdir ebuild flags = do let edir = pkgdir elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild" epath = edir </> elocal emeta = "metadata.xml" mpath = edir </> emeta- default_meta = BL.pack $ Portage.makeDefaultMetadata (E.long_desc ebuild)+ default_meta = BL.pack $ Portage.makeDefaultMetadata (E.long_desc ebuild) (metaFlags flags) createDirectoryIfMissing True edir now <- TC.getCurrentTime
Merge/Dependencies.hs view
@@ -16,6 +16,7 @@ import qualified Distribution.PackageDescription as Cabal import qualified Distribution.Version as Cabal import qualified Distribution.Text as Cabal+import qualified Distribution.Types.ExeDependency as Cabal import qualified Distribution.Types.LegacyExeDependency as Cabal import qualified Distribution.Types.PkgconfigDependency as Cabal @@ -104,7 +105,7 @@ then [] else [any_c_p "virtual" "pkgconfig"] build_tools :: Portage.Dependency- build_tools = Portage.DependAllOf $ pkg_config_tools : buildToolsDependencies pkg+ build_tools = Portage.DependAllOf $ pkg_config_tools : legacyBuildToolsDependencies pkg ++ hackageBuildToolsDependencies overlay pkg setup_deps :: Portage.Dependency setup_deps = PN.normalize_depend $ Portage.DependAllOf $@@ -352,14 +353,16 @@ , ("notify", any_c_p "x11-libs" "libnotify") , ("SDL2", any_c_p " media-libs" "libsdl2") , ("SDL2_mixer", any_c_p "media-libs" "sdl2-mixer")+ , ("blas", any_c_p "virtual" "blas")+ , ("lapack", any_c_p "virtual" "lapack") ] ------------------------------------------------------------------ Build Tools+-- Build Tools (legacy, a list of well-known tools) --------------------------------------------------------------- -buildToolsDependencies :: Cabal.PackageDescription -> [Portage.Dependency]-buildToolsDependencies (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = L.nub $+legacyBuildToolsDependencies :: Cabal.PackageDescription -> [Portage.Dependency]+legacyBuildToolsDependencies (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = L.nub $ [ case pkg of Just p -> p Nothing -> trace ("WARNING: Unknown build tool '" ++ Cabal.display exe ++ "'. Check the generated ebuild.")@@ -395,7 +398,21 @@ buildToolsProvided :: [String] buildToolsProvided = ["hsc2hs"] +---------------------------------------------------------------+-- Hackage Build Tools (behind `build-tool-depends`)+--------------------------------------------------------------- +hackageBuildToolsDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Portage.Dependency]+hackageBuildToolsDependencies overlay (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) =+ haskellDependencies overlay $ L.nub $+ [ Cabal.Dependency pn versionRange+ | Cabal.ExeDependency pn _component versionRange <- cabalDeps+ ]+ where+ cabalDeps = depL ++ depE+ depL = concatMap (Cabal.buildToolDepends . Cabal.libBuildInfo) $ maybe [] return lib+ depE = concatMap Cabal.buildToolDepends (filter Cabal.buildable (map Cabal.buildInfo exes))+ --------------------------------------------------------------- -- pkg-config ---------------------------------------------------------------@@ -436,6 +453,8 @@ ,("gmodule-export-2.0", ("dev-libs", "glib", Portage.GivenSlot "2")) ,("gmodule-no-export-2.0", ("dev-libs", "glib", Portage.GivenSlot "2")) ,("gobject-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))+ ,("gobject-introspection-1.0", ("dev-libs", "gobject-introspection",+ Portage.AnySlot)) ,("gthread-2.0", ("dev-libs", "glib", Portage.GivenSlot "2")) ,("gtk+-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
Portage/EBuild.hs view
@@ -91,10 +91,10 @@ showEBuild :: TC.UTCTime -> EBuild -> String showEBuild now ebuild =- ss ("# Copyright 1999-" ++ this_year ++ " Gentoo Foundation"). nl.+ ss ("# Copyright 1999-" ++ this_year ++ " Gentoo Authors"). nl. ss "# Distributed under the terms of the GNU General Public License v2". nl. nl.- ss "EAPI=6". nl.+ ss "EAPI=7". nl. nl. ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl. sconcat (map (\(k, v) -> ss "#hackport: " . ss k . ss ": " . ss v . nl) $ used_options ebuild).
Portage/GHCCore.hs view
@@ -31,7 +31,7 @@ -- It means that first ghc in this list is a minmum default. ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)] ghcs = modern_ghcs- where modern_ghcs = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101, ghc7102, ghc801, ghc802, ghc821]+ where modern_ghcs = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101, ghc7102, ghc801, ghc802, ghc821, ghc843, ghc861, ghc863] cabalFromGHC :: [Int] -> Maybe Cabal.Version cabalFromGHC ver = lookup ver table@@ -45,6 +45,8 @@ , ([8,0,1], Cabal.mkVersion [1,24,0,0]) , ([8,0,2], Cabal.mkVersion [1,24,2,0]) , ([8,2,1], Cabal.mkVersion [2,0,0,2])+ , ([8,4,3], Cabal.mkVersion [2,2,0,1])+ , ([8,6,1], Cabal.mkVersion [2,4,0,1]) ] platform :: Platform@@ -114,6 +116,15 @@ ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag where c_id = CompilerId GHC (mkVersion nrs) +ghc863 :: (DC.CompilerInfo, InstalledPackageIndex)+ghc863 = (ghc [8,6,3], mkIndex ghc863_pkgs)++ghc861 :: (DC.CompilerInfo, InstalledPackageIndex)+ghc861 = (ghc [8,6,1], mkIndex ghc861_pkgs)++ghc843 :: (DC.CompilerInfo, InstalledPackageIndex)+ghc843 = (ghc [8,4,3], mkIndex ghc843_pkgs)+ ghc821 :: (DC.CompilerInfo, InstalledPackageIndex) ghc821 = (ghc [8,2,1], mkIndex ghc821_pkgs) @@ -147,6 +158,106 @@ -- | Non-upgradeable core packages -- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC -- and our binary tarballs (package.conf.d.initial subdir)+++ghc863_pkgs :: [Cabal.PackageIdentifier]+ghc863_pkgs =+ [ p "array" [0,5,3,0]+ , p "base" [4,12,0,0]+ , p "binary" [0,8,6,0] -- used by libghc+ , p "bytestring" [0,10,8,2]+-- , p "Cabal" [2,4,0,1] package is upgradeable+ , p "containers" [0,6,0,1]+ , p "deepseq" [1,4,4,0] -- used by time+ , p "directory" [1,3,3,0]+ , p "filepath" [1,4,2,1]+ , p "ghc-boot" [8,6,3] + , p "ghc-boot-th" [8,6,3] + , p "ghc-compact" [0,1,0,0]+ , p "ghc-prim" [0,5,3,0]+ , p "ghci" [8,6,3]+-- , p "haskeline" [0,7,4,3] package is upgradeable+ , p "hpc" [0,6,0,3] -- used by libghc+ , p "integer-gmp" [1,0,2,0]+ -- , p "mtl" [2,2,2] package is upgradeable(?)+ -- , p "parsec" [3,1,13,0] package is upgradeable(?)+ , p "pretty" [1,1,3,6]+ , p "process" [1,6,3,0]+ -- , p "stm" [2,5,0,0] package is upgradeable(?)+ , p "template-haskell" [2,14,0,0] -- used by libghc+ -- , p "terminfo" [0,4,1,2]+ -- , p "text" [1,2,3,1] dependency of Cabal library+ , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade+ , p "transformers" [0,5,5,0] -- used by libghc+ , p "unix" [2,7,2,2]+-- , p "xhtml" [3000,2,2,1]+ ]++ghc861_pkgs :: [Cabal.PackageIdentifier]+ghc861_pkgs =+ [ p "array" [0,5,2,0]+ , p "base" [4,12,0,0]+ , p "binary" [0,8,6,0] -- used by libghc+ , p "bytestring" [0,10,8,2]+-- , p "Cabal" [2,4,0,1] package is upgradeable+ , p "containers" [0,6,0,1]+ , p "deepseq" [1,4,4,0] -- used by time+ , p "directory" [1,3,3,0]+ , p "filepath" [1,4,2,1]+ , p "ghc-boot" [8,6,1] + , p "ghc-boot-th" [8,6,1] + , p "ghc-compact" [0,1,0,0]+ , p "ghc-prim" [0,5,3,0]+ , p "ghci" [8,6,1]+-- , p "haskeline" [0,7,4,3] package is upgradeable+ , p "hpc" [0,6,0,3] -- used by libghc+ , p "integer-gmp" [1,0,2,0]+ -- , p "mtl" [2,2,2] package is upgradeable(?)+ -- , p "parsec" [3,1,13,0] package is upgradeable(?)+ , p "pretty" [1,1,3,6]+ , p "process" [1,6,3,0]+ -- , p "stm" [2,5,0,0] package is upgradeable(?)+ , p "template-haskell" [2,14,0,0] -- used by libghc+ -- , p "terminfo" [0,4,1,2]+ -- , p "text" [1,2,3,1] dependency of Cabal library+ , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade+ , p "transformers" [0,5,5,0] -- used by libghc+ , p "unix" [2,7,2,2]+-- , p "xhtml" [3000,2,2,1]+ ]++ghc843_pkgs :: [Cabal.PackageIdentifier]+ghc843_pkgs =+ [ p "array" [0,5,2,0]+ , p "base" [4,11,1,0]+ , p "binary" [0,8,5,1] -- used by libghc+ , p "bytestring" [0,10,8,2]+-- , p "Cabal" [2,2,0,1] package is upgradeable+ , p "containers" [0,5,11,2]+ , p "deepseq" [1,4,3,0] -- used by time+ , p "directory" [1,3,1,5]+ , p "filepath" [1,4,2]+ , p "ghc-boot" [8,4,3]+ , p "ghc-boot-th" [8,4,3]+ , p "ghc-compact" [0,1,0,0]+ , p "ghc-prim" [0,5,2,0]+ , p "ghci" [8,4,3]+-- , p "haskeline" [0,7,4,2] package is upgradeable+ , p "hpc" [0,6,0,3] -- used by libghc+ , p "integer-gmp" [1,0,2,0]+ -- , p "mtl" [2,2,2] package is upgradeable(?)+ -- , p "parsec" [3,1,13,0] package is upgradeable(?)+ , p "pretty" [1,1,3,6]+ , p "process" [1,6,3,0]+ -- , p "stm" [2,4,5,0] package is upgradeable(?)+ , p "template-haskell" [2,13,0,0] -- used by libghc+ -- , p "terminfo" [0,4,1,1]+ -- , p "text" [1,2,3,0]+ , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade+ , p "transformers" [0,5,5,0] -- used by libghc+ , p "unix" [2,7,2,2]+-- , p "xhtml" [3000,2,2,1]+ ] ghc821_pkgs :: [Cabal.PackageIdentifier] ghc821_pkgs =
Portage/Metadata.hs view
@@ -25,9 +25,13 @@ parseMetadata xml = return Metadata { metadata_emails = map strContent (findElements (unqual "email") xml) } +formatFlags :: (String, String) -> String+formatFlags (name, description) = "\t\t<flag name=\"" ++ name +++ "\">" ++ description ++ "</flag>"+ -- don't use Text.XML.Light as we like our own pretty printer-makeDefaultMetadata :: String -> String-makeDefaultMetadata long_description =+makeDefaultMetadata :: String -> [(String, String)] -> String+makeDefaultMetadata long_description flags = unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">" , "<pkgmetadata>"@@ -35,6 +39,10 @@ , "\t\t<email>haskell@gentoo.org</email>" , "\t\t<name>Gentoo Haskell</name>" , "\t</maintainer>"+ , if (formatFlags <$> flags) == [""]+ then "\t<use>\n\t</use>"+ else "\t<use>\n" ++ (unlines $ formatFlags <$> flags) +++ "\t</use>" , (init {- strip trailing newline-} . unlines . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]
cabal/Cabal/Distribution/PackageDescription/Configuration.hs view
@@ -56,7 +56,8 @@ import Distribution.Types.Condition import Distribution.Types.DependencyMap -import qualified Data.Map as Map+import qualified Data.Map.Strict as Map.Strict+import qualified Data.Map.Lazy as Map import Data.Tree ( Tree(Node) ) ------------------------------------------------------------------------------@@ -219,7 +220,7 @@ mp m@(Right _) _ = m mp _ m@(Right _) = m mp (Left xs) (Left ys) =- let union = Map.foldrWithKey (Map.insertWith' combine)+ let union = Map.foldrWithKey (Map.Strict.insertWith combine) (unDepMapUnion xs) (unDepMapUnion ys) combine x y = simplifyVersionRange $ unionVersionRanges x y in union `seq` Left (DepMapUnion union)
+ hackage-security/.appveyor.yml view
@@ -0,0 +1,31 @@+version: "{build}"+clone_folder: "c:\\WORK"++environment:+ global:+ CABOPTS: "--store-dir=C:\\SR --http-transport=plain-http"+ matrix:+ - GHCVER: "8.2.2"+ - GHCVER: "8.0.2"+# temporarily disabled until https://github.com/snoyberg/http-client/issues/327 is resolved+# - GHCVER: "7.10.3.2"+# - GHCVER: "7.8.4"++cache:+ - "C:\\SR"++install:+ - "choco install -y ghc --version %GHCVER%"+ - "refreshenv"+ - "set PATH=C:\\msys64\\mingw64\\bin;C:\\msys64\\usr\\bin;%PATH%"+ - "cabal --version"+ - "ghc --version"+ - "cabal %CABOPTS% update -vverbose+nowrap"++build: off++test_script:+ - "cabal %CABOPTS% new-build -j1 -vnormal+nowrap --dry all"+ - ps: Push-AppveyorArtifact dist-newstyle\cache\plan.json+ - "cabal %CABOPTS% new-build -j1 -vnormal+nowrap all"+ - "cabal %CABOPTS% new-test -j1 -vnormal+nowrap all"
hackage-security/.gitignore view
@@ -1,6 +1,9 @@ tags+TAGS prototype-state/client/ prototype-state/server/ prototype-state/offline/ .stack-work/ dist-newstyle+.ghc.environment.*+cabal.project.local
hackage-security/.travis.yml view
@@ -26,18 +26,18 @@ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}} - compiler: "ghc-7.10.3" addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}- - compiler: "ghc-8.0.1"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.1], sources: [hvr-ghc]}} - compiler: "ghc-8.0.2" addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.2.1"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}+ - compiler: "ghc-8.2.2"+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-8.4.3"+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.3], sources: [hvr-ghc]}} before_install: - HC=${CC} - unset CC - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH- + install: - cabal --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
hackage-security/README.md view
@@ -1,4 +1,4 @@-# Hackage Security+# Hackage Security [](https://hackage.haskell.org/package/hackage-security) [](https://www.stackage.org/package/hackage-security) [](http://travis-ci.org/haskell/hackage-security) [](https://ci.appveyor.com/project/hvr/hackage-security) This is a library for Hackage security based on [TUF, The Update Framework][TUF].
hackage-security/example-client/example-client.cabal view
@@ -43,6 +43,6 @@ -- see comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7,- network >= 2.6 && < 2.7+ network >= 2.6 && < 2.8 else build-depends: network >= 2.5 && < 2.6
hackage-security/hackage-repo-tool/ChangeLog.md view
@@ -1,11 +1,16 @@+0.1.1.1+-------+* Make `hackage-repo-tool` buildable on Windows (#175)+* Fix build-failure w/ `directory-1.2`+ 0.1.1 ------* Update for hackage-security-0.5+* Update for `hackage-security-0.5` 0.1.0.1 ------- * Add missing module to other-modules (#100)-* Allow for hackage-security-0.3+* Allow for `hackage-security-0.3` * Include ChangeLog.md in sdist (#98) 0.1.0.0
hackage-security/hackage-repo-tool/hackage-repo-tool.cabal view
@@ -1,36 +1,44 @@+cabal-version: 1.12 name: hackage-repo-tool-version: 0.1.1+version: 0.1.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- index tarball). Currently it also provides various- lower level utilities for creating and signing TUF files.+description: This utility can be used to manage secure file-based package+ repositories (creating [TUF](https://theupdateframework.github.io/)+ metadata as well as a Hackage index tarball) which can be used by+ clients such as [cabal-install](http://hackage.haskell.org/package/cabal-install).+ 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/+ This is part of the [Hackage Security](https://github.com/haskell/hackage-security#readme)+ infrastructure. license: BSD3 license-file: LICENSE author: Edsko de Vries-maintainer: edsko@well-typed.com+maintainer: cabal-devel@haskell.org 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+homepage: https://github.com/haskell/hackage-security+bug-reports: https://github.com/haskell/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+ location: https://github.com/haskell/hackage-security.git flag use-network-uri- description: Are we using network-uri?+ description: Are we using @network-uri@? manual: False +flag use-old-time+ description: Are we using @old-time@?+ manual: False+ executable hackage-repo-tool+ hs-source-dirs: src main-is: Main.hs other-modules: Hackage.Security.RepoTool.Options Hackage.Security.RepoTool.Layout@@ -38,18 +46,33 @@ Hackage.Security.RepoTool.Paths Hackage.Security.RepoTool.Util.IO Prelude- build-depends: base >= 4.4 && < 5,- Cabal >= 1.12 && < 2.1,++ build-depends: base >= 4.5 && < 5,+ Cabal >= 1.14 && < 2.4, bytestring >= 0.9 && < 0.11, directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5,- optparse-applicative >= 0.11 && < 0.14,+ optparse-applicative >= 0.11 && < 0.15, tar >= 0.4 && < 0.6, time >= 1.2 && < 1.9,- unix >= 2.5 && < 2.8, zlib >= 0.5 && < 0.7, hackage-security >= 0.5 && < 0.6- hs-source-dirs: src+ if !os(windows)+ build-depends: unix >= 2.5 && < 2.8++ if flag(use-old-time)+ build-depends: directory < 1.2+ , old-time == 1.1.*+ else+ build-depends: directory >= 1.2++ -- see comments in hackage-security.cabal+ if flag(use-network-uri)+ build-depends: network-uri >= 2.6 && < 2.7,+ network >= 2.6 && < 2.8+ else+ build-depends: network >= 2.5 && < 2.6+ default-language: Haskell2010 default-extensions: DeriveDataTypeable FlexibleContexts@@ -58,12 +81,5 @@ 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+ ghc-options: -Wall
hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Options.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Hackage.Security.RepoTool.Options ( GlobalOpts(..) , Command(..)@@ -60,8 +61,10 @@ -- | Create mirrors metadata | CreateMirrors KeysLoc (Path Absolute) [URI] +#ifndef mingw32_HOST_OS -- | Create a directory with symlinks in cabal-local-rep layout | SymlinkCabalLocalRepo RepoLoc RepoLoc+#endif -- | Sign an individual file | Sign [KeyLoc] DeleteExistingSignatures (Path Absolute)@@ -123,6 +126,7 @@ ]) <*> (many $ argument (str >>= readURI) (metavar "MIRROR")) +#ifndef mingw32_HOST_OS parseSymlinkCabalLocalRepo :: Parser Command parseSymlinkCabalLocalRepo = SymlinkCabalLocalRepo <$> parseRepoLoc@@ -130,6 +134,7 @@ long "cabal-repo" , help "Location of the cabal repo" ])+#endif parseSign :: Parser Command parseSign = Sign@@ -181,8 +186,10 @@ 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."+#ifndef mingw32_HOST_OS , command "symlink-cabal-local-repo" $ info (helper <*> parseSymlinkCabalLocalRepo) $ progDesc "Create a directory in cabal-local-repo layout with symlinks to the specified repository."+#endif , command "sign" $ info (helper <*> parseSign) $ progDesc "Sign a file" ])
hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Util/IO.hs view
@@ -4,40 +4,59 @@ -- * Miscellaneous compress , getFileModTime+#ifndef mingw32_HOST_OS , createSymbolicLink+#endif -- * 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+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip as GZip+import Control.Exception+import qualified Data.ByteString.Lazy as BS.L+import Data.Typeable+import qualified System.Directory as Directory+import System.IO.Error -- hackage-security-import Hackage.Security.Util.Path+import Hackage.Security.Util.Path -- hackage-repo-tool-import Hackage.Security.RepoTool.Options-import Hackage.Security.RepoTool.Layout-import Hackage.Security.RepoTool.Paths+import Hackage.Security.RepoTool.Layout+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Paths +import System.Posix.Types (EpochTime)+#ifndef mingw32_HOST_OS+import qualified System.Posix.Files as Posix+#endif++#if MIN_VERSION_directory(1,2,0)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+#else+import System.Time (ClockTime (TOD))+#endif+ -- | 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)+ -- Underlying implementation of 'Directory.getModificationTime' converts+ -- from POSIX seconds, so there shouldn't be loss of precision.+ -- NB: Apparently, this has low clock resolution on GHC < 7.8.+ -- I don't think we care.+#if MIN_VERSION_directory(1,2,0)+ fromInteger . floor . utcTimeToPOSIXSeconds+ <$> Directory.getModificationTime (toFilePath fp)+#else+ Directory.getModificationTime (toFilePath fp) >>= \(TOD s _) ->+ return (fromInteger s)+#endif where fp :: Path Absolute fp = anchorTargetPath' opts repoLoc targetPath@@ -51,6 +70,7 @@ withFile dst WriteMode $ \h -> BS.L.hPut h =<< GZip.compress <$> readLazyByteString src +#ifndef mingw32_HOST_OS -- | Create a symbolic link (unix only) -- -- Create the directory for the target if it does not exist.@@ -66,6 +86,7 @@ linkTarget' <- toAbsoluteFilePath linkTarget linkLoc' <- toAbsoluteFilePath linkLoc Posix.createSymbolicLink linkTarget' linkLoc'+#endif {------------------------------------------------------------------------------- Working with tar archives
hackage-security/hackage-repo-tool/src/Main.hs view
@@ -9,10 +9,13 @@ 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 +#ifndef mingw32_HOST_OS+import System.IO.Error (isAlreadyExistsError)+#endif+ -- Cabal import Distribution.Package import Distribution.Text@@ -54,8 +57,10 @@ createRoot opts keysLoc rootLoc CreateMirrors keysLoc mirrorsLoc mirrors -> createMirrors opts keysLoc mirrorsLoc mirrors+#ifndef mingw32_HOST_OS SymlinkCabalLocalRepo repoLoc cabalRepoLoc -> symlinkCabalLocalRepo opts repoLoc cabalRepoLoc+#endif Sign keys deleteExisting file -> signFile keys deleteExisting file @@ -489,7 +494,7 @@ -- 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)+updateFile :: forall a. (ToJSON WriteJSON a, HasHeader a) => GlobalOpts -> RepoLoc -> WhenWrite@@ -597,6 +602,7 @@ expectedTarGz :: TargetPath' expectedTarGz = InRepPkg repoLayoutPkgTarGz pkgId +#ifndef mingw32_HOST_OS {------------------------------------------------------------------------------- Creating Cabal-local-repo -------------------------------------------------------------------------------}@@ -621,6 +627,7 @@ target = anchorRepoPath opts repoLoc file loc = anchorRepoPath opts' cabalRepoLoc file opts' = opts { globalRepoLayout = cabalLocalRepoLayout }+#endif {------------------------------------------------------------------------------- Signing individual files
hackage-security/hackage-root-tool/hackage-root-tool.cabal view
@@ -27,7 +27,7 @@ main-is: Main.hs build-depends: base >= 4.4 && < 5, filepath >= 1.2 && < 1.5,- optparse-applicative >= 0.11 && < 0.14,+ optparse-applicative >= 0.11 && < 0.15, hackage-security >= 0.5 && < 0.6 default-language: Haskell2010 other-extensions: CPP, ScopedTypeVariables, RecordWildCards
hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal view
@@ -5,15 +5,14 @@ abstraction to allow to bind against different HTTP libraries. This library implements this abstraction using the @HTTP@ library.-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-homepage: https://github.com/well-typed/hackage-security-bug-reports: https://github.com/well-typed/hackage-security/issues+homepage: https://github.com/haskell/hackage-security+bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple cabal-version: >=1.10 @@ -22,7 +21,7 @@ source-repository head type: git- location: https://github.com/well-typed/hackage-security.git+ location: https://github.com/haskell/hackage-security.git flag use-network-uri description: Are we using network-uri?@@ -50,6 +49,6 @@ -- See comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7,- network >= 2.6 && < 2.7+ network >= 2.6 && < 2.8 else build-depends: network >= 2.5 && < 2.6
hackage-security/hackage-security-curl/hackage-security-curl.cabal view
@@ -28,6 +28,6 @@ -- See comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7,- network >= 2.6 && < 2.7+ network >= 2.6 && < 2.8 else build-depends: network >= 2.5 && < 2.6
hackage-security/hackage-security-http-client/hackage-security-http-client.cabal view
@@ -34,6 +34,6 @@ -- see comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7,- network >= 2.6 && < 2.7+ network >= 2.6 && < 2.8 else build-depends: network >= 2.5 && < 2.6
hackage-security/hackage-security/ChangeLog.md view
@@ -1,3 +1,18 @@+unreleased+----------++* Allow `network-2.7.0.0`+* Allow `aeson-1.4.0.0`++0.5.3.0+-------++* Use `flock(2)`-based locking where available+ (compat-shim taken from `cabal-install`'s code-base) (#207)+* Improve handling of async exceptions (#187)+* Detect & recover from local corruption of uncompressed index tarball (#196)+* Support `base-4.11`+ 0.5.2.2 -------
hackage-security/hackage-security/hackage-security.cabal view
@@ -1,5 +1,7 @@+cabal-version: 1.12 name: hackage-security-version: 0.5.2.2+version: 0.5.3.0+ synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server@@ -21,13 +23,12 @@ license: BSD3 license-file: LICENSE author: Edsko de Vries-maintainer: edsko@well-typed.com+maintainer: cabal-devel@haskell.org copyright: Copyright 2015-2016 Well-Typed LLP category: Distribution homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple-cabal-version: >=1.10 extra-source-files: ChangeLog.md@@ -37,15 +38,15 @@ location: https://github.com/haskell/hackage-security.git flag base48- description: Are we using base 4.8 or later?+ description: Are we using @base@ 4.8 or later? manual: False flag use-network-uri- description: Are we using network-uri?+ description: Are we using @network-uri@? manual: False -Flag old-directory- description: Use directory < 1.2 and old-time+flag old-directory+ description: Use @directory@ < 1.2 and @old-time@ manual: False default: False @@ -90,17 +91,19 @@ Hackage.Security.TUF.Targets Hackage.Security.TUF.Timestamp Hackage.Security.Util.Base64+ Hackage.Security.Util.Exit+ Hackage.Security.Util.FileLock Hackage.Security.Util.JSON Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded Prelude -- We support ghc 7.4 (bundled with Cabal 1.14) and up- build-depends: base >= 4.5 && < 5,+ build-depends: base >= 4.5 && < 4.13, base16-bytestring >= 0.1.1 && < 0.2, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.9 && < 0.11,- Cabal >= 1.14 && < 2.2,- containers >= 0.4 && < 0.6,+ Cabal >= 1.14 && < 2.6,+ containers >= 0.4 && < 0.7, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, mtl >= 2.2 && < 2.3,@@ -121,6 +124,8 @@ old-time >= 1 && < 1.2 else build-depends: directory >= 1.2 && < 1.4+ build-tool-depends: hsc2hs:hsc2hs >= 0.67 && <0.69+ hs-source-dirs: src default-language: Haskell2010 default-extensions: DefaultSignatures@@ -195,7 +200,7 @@ -- dependency in network is not redundant.) if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7,- network >= 2.6 && < 2.7+ network >= 2.6 && < 2.9 else build-depends: network >= 2.5 && < 2.6 @@ -204,9 +209,7 @@ if impl(ghc >= 7.10) other-extensions: AllowAmbiguousTypes--- StaticPointers--- ^^^ Temporarily disabled because Hackage doesn't know yet about this--- extension and will therefore reject this package.+ StaticPointers test-suite TestSuite type: exitcode-stdio-1.0@@ -218,21 +221,28 @@ TestSuite.JSON TestSuite.PrivateKeys TestSuite.Util.StrictMVar- build-depends: base,++ -- inherited constraints from lib:hackage-security component+ build-depends: hackage-security,+ base, Cabal, containers,- HUnit, bytestring,- hackage-security, network-uri, tar,- tasty,- tasty-hunit,- tasty-quickcheck,- QuickCheck,- temporary, time, zlib++ -- dependencies exclusive to test-suite+ build-depends: tasty == 1.0.*,+ tasty-hunit == 0.10.*,+ tasty-quickcheck == 0.10.*,+ QuickCheck == 2.11.*,+ aeson == 1.4.*,+ vector == 0.12.*,+ unordered-containers >=0.2.8.0 && <0.3,+ temporary == 1.2.*+ hs-source-dirs: tests default-language: Haskell2010 default-extensions: FlexibleContexts
hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs view
@@ -16,6 +16,7 @@ import Control.Exception import Control.Monad+import Control.Monad.IO.Class import Data.Maybe import Codec.Archive.Tar (Entries(..)) import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset)@@ -29,6 +30,7 @@ import Hackage.Security.Client.Formats import Hackage.Security.TUF import Hackage.Security.Util.Checked+import Hackage.Security.Util.Exit import Hackage.Security.Util.IO import Hackage.Security.Util.Path @@ -65,21 +67,47 @@ unzipIndex :: IO () unzipIndex = do createDirectoryIfMissing True (takeDirectory indexUn)- shouldTryIncremenal <- cachedIndexProbablyValid- if shouldTryIncremenal- then unzipIncremenal- else unzipNonIncremenal+ shouldTryIncremental <- cachedIndexProbablyValid+ if shouldTryIncremental+ then do+ success <- unzipIncremental+ unless success unzipNonIncremental+ else unzipNonIncremental where- unzipIncremenal = do+ unzipIncremental = do compressed <- readLazyByteString indexGz let uncompressed = GZip.decompress compressed- withFile indexUn ReadWriteMode $ \h -> do- currentSize <- hFileSize h++ -- compare prefix of old index with prefix of new index to+ -- ensure that it's safe to incrementally append+ (seekTo',newTail') <- withFile indexUn ReadMode $ \h ->+ multipleExitPoints $ do+ currentSize <- liftIO $ hFileSize h let seekTo = 0 `max` (currentSize - tarTrailer)- hSeek h AbsoluteSeek seekTo- BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed+ (newPrefix,newTail) = BS.L.splitAt (fromInteger seekTo)+ uncompressed - unzipNonIncremenal = do+ (oldPrefix,oldTrailer) <- BS.L.splitAt (fromInteger seekTo) <$>+ liftIO (BS.L.hGetContents h)++ unless (oldPrefix == newPrefix) $+ exit (0,mempty) -- corrupted index.tar prefix++ -- sanity check: verify there's a 1KiB zero-filled trailer+ unless (oldTrailer == tarTrailerBs) $+ exit (0,mempty) -- corrupted .tar trailer++ return (seekTo,newTail)++ if seekTo' <= 0+ then return False -- fallback to non-incremental update+ else withFile indexUn ReadWriteMode $ \h -> do+ -- everything seems fine; append the new data+ liftIO $ hSeek h AbsoluteSeek seekTo'+ liftIO $ BS.L.hPut h newTail'+ return True++ unzipNonIncremental = do compressed <- readLazyByteString indexGz let uncompressed = GZip.decompress compressed withFile indexUn WriteMode $ \h ->@@ -107,6 +135,8 @@ tarTrailer :: Integer tarTrailer = 1024++ tarTrailerBs = BS.L.replicate (fromInteger tarTrailer) 0x00 -- | Rebuild the tarball index --
hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs view
@@ -30,7 +30,6 @@ import Control.Concurrent import Control.Exception import Control.Monad.Cont-import Control.Monad.Except import Data.List (nub, intercalate) import Data.Typeable import Network.URI hiding (uriPath, path)@@ -50,6 +49,7 @@ import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty import Hackage.Security.Util.Some+import Hackage.Security.Util.Exit import qualified Hackage.Security.Client.Repository.Cache as Cache {-------------------------------------------------------------------------------@@ -686,39 +686,3 @@ , temp ] -{-------------------------------------------------------------------------------- Auxiliary: multiple exit points--------------------------------------------------------------------------------}---- | Multiple exit points------ We can simulate the imperative code------ > if (cond1)--- > return exp1;--- > if (cond2)--- > return exp2;--- > if (cond3)--- > return exp3;--- > return exp4;------ as------ > multipleExitPoints $ do--- > when (cond1) $--- > exit exp1--- > when (cond) $--- > exit exp2--- > when (cond)--- > exit exp3--- > return exp4-multipleExitPoints :: Monad m => ExceptT a m a -> m a-multipleExitPoints = liftM aux . runExceptT- where- aux :: Either a a -> a- aux (Left a) = a- aux (Right a) = a---- | Function exit point (see 'multipleExitPoints')-exit :: Monad m => e -> ExceptT e m a-exit = throwError
hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs view
@@ -9,6 +9,8 @@ {-# LANGUAGE IncoherentInstances #-} #endif +{-# LANGUAGE DeriveDataTypeable#-}+ -- | Checked exceptions module Hackage.Security.Util.Checked ( Throws@@ -25,6 +27,7 @@ import Control.Exception (Exception, IOException) import qualified Control.Exception as Base+import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ >= 708 import GHC.Prim (coerce)@@ -50,14 +53,48 @@ Base exceptions -------------------------------------------------------------------------------} +-- | Determine if an exception is asynchronous, based on its type.+isAsync :: Exception e => e -> Bool+#if MIN_VERSION_base(4, 7, 0)+isAsync e =+ case Base.fromException $ Base.toException e of+ Just Base.SomeAsyncException{} -> True+ Nothing -> False+#else+-- Earlier versions of GHC had no SomeAsyncException. We have to+-- instead make up a list of async exceptions.+isAsync e =+ let se = Base.toException e+ in case () of+ ()+ | Just (_ :: Base.AsyncException) <- Base.fromException se -> True+ | show e == "<<timeout>>" -> True+ | otherwise -> False+#endif++-- | 'Base.catch', but immediately rethrows asynchronous exceptions+-- (as determined by 'isAsync').+catchSync :: Exception e => IO a -> (e -> IO a) -> IO a+catchSync act onErr = act `Base.catch` \e ->+ if isAsync e+ then Base.throwIO e+ else onErr e++-- | Wraps up an async exception as a synchronous exception.+newtype SyncException = SyncException Base.SomeException+ deriving (Show, Typeable)+instance Exception SyncException+ -- | Throw a checked exception throwChecked :: (Exception e, Throws e) => e -> IO a-throwChecked = Base.throwIO+throwChecked e+ | isAsync e = Base.throwIO $ SyncException $ Base.toException e+ | otherwise = Base.throwIO e -- | Catch a checked exception catchChecked :: forall a e. Exception e => (Throws e => IO a) -> (e -> IO a) -> IO a-catchChecked act = Base.catch (unthrow (Proxy :: Proxy e) act)+catchChecked act = catchSync (unthrow (Proxy :: Proxy e) act) -- | 'catchChecked' with the arguments reversed handleChecked :: Exception e => (e -> IO a) -> (Throws e => IO a) -> IO a
+ hackage-security/hackage-security/src/Hackage/Security/Util/Exit.hs view
@@ -0,0 +1,40 @@+module Hackage.Security.Util.Exit where++import Control.Monad.Except++{-------------------------------------------------------------------------------+ Auxiliary: multiple exit points+-------------------------------------------------------------------------------}++-- | Multiple exit points+--+-- We can simulate the imperative code+--+-- > if (cond1)+-- > return exp1;+-- > if (cond2)+-- > return exp2;+-- > if (cond3)+-- > return exp3;+-- > return exp4;+--+-- as+--+-- > multipleExitPoints $ do+-- > when (cond1) $+-- > exit exp1+-- > when (cond2) $+-- > exit exp2+-- > when (cond3) $+-- > exit exp3+-- > return exp4+multipleExitPoints :: Monad m => ExceptT a m a -> m a+multipleExitPoints = liftM aux . runExceptT+ where+ aux :: Either a a -> a+ aux (Left a) = a+ aux (Right a) = a++-- | Function exit point (see 'multipleExitPoints')+exit :: Monad m => e -> ExceptT e m a+exit = throwError
+ hackage-security/hackage-security/src/Hackage/Security/Util/FileLock.hsc view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum+-- required version. Though note that the locking functionality is not in+-- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module.+--+-- Copied from @cabal-install@ codebase "Distribution.Client.Compat.FileLock".+module Hackage.Security.Util.FileLock (+ FileLockingNotSupported(..)+ , LockMode(..)+ , hLock+ , hTryLock+ ) where++#if MIN_VERSION_base(4,10,0)++import GHC.IO.Handle.Lock++#else++-- The remainder of this file is a modified copy+-- of GHC.IO.Handle.Lock from ghc-8.2.x+--+-- The modifications were just to the imports and the CPP, since we do not have+-- access to the HAVE_FLOCK from the ./configure script. We approximate the+-- lack of HAVE_FLOCK with @defined(solaris2_HOST_OS) || defined(aix_HOST_OS)@+-- instead since those are known major Unix platforms lacking @flock()@ or+-- having broken one.++import Control.Exception (Exception)+import Data.Typeable++#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)++import Control.Exception (throwIO)+import System.IO (Handle)++#else++import Data.Bits+import Data.Function+import Control.Concurrent.MVar++import Foreign.C.Error+import Foreign.C.Types++import GHC.IO.Handle.Types+import GHC.IO.FD+import GHC.IO.Exception++#if defined(mingw32_HOST_OS)++#if defined(i386_HOST_ARCH)+## define WINDOWS_CCONV stdcall+#elif defined(x86_64_HOST_ARCH)+## define WINDOWS_CCONV ccall+#else+# error Unknown mingw32 arch+#endif++#include <windows.h>++import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import GHC.Windows++#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */++#include <sys/file.h>++#endif /* !defined(mingw32_HOST_OS) */++#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */+++-- | Exception thrown by 'hLock' on non-Windows platforms that don't support+-- 'flock'.+data FileLockingNotSupported = FileLockingNotSupported+ deriving (Typeable, Show)++instance Exception FileLockingNotSupported+++-- | Indicates a mode in which a file should be locked.+data LockMode = SharedLock | ExclusiveLock++-- | If a 'Handle' references a file descriptor, attempt to lock contents of the+-- underlying file in appropriate mode. If the file is already locked in+-- incompatible mode, this function blocks until the lock is established. The+-- lock is automatically released upon closing a 'Handle'.+--+-- Things to be aware of:+--+-- 1) This function may block inside a C call. If it does, in order to be able+-- to interrupt it with asynchronous exceptions and/or for other threads to+-- continue working, you MUST use threaded version of the runtime system.+--+-- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,+-- hence all of their caveats also apply here.+--+-- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this+-- function throws 'FileLockingNotImplemented'. We deliberately choose to not+-- provide fcntl based locking instead because of its broken semantics.+--+-- @since 4.10.0.0+hLock :: Handle -> LockMode -> IO ()+hLock h mode = lockImpl h "hLock" mode True >> return ()++-- | Non-blocking version of 'hLock'.+--+-- @since 4.10.0.0+hTryLock :: Handle -> LockMode -> IO Bool+hTryLock h mode = lockImpl h "hTryLock" mode False++----------------------------------------++#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)++-- | No-op implementation.+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool+lockImpl _ _ _ _ = throwIO FileLockingNotSupported++#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */++#if defined(mingw32_HOST_OS)++lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool+lockImpl h ctx mode block = do+ FD{fdFD = fd} <- handleToFd h+ wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd+ allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do+ fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0+ let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})+ -- We want to lock the whole file without looking up its size to be+ -- consistent with what flock does. According to documentation of LockFileEx+ -- "locking a region that goes beyond the current end-of-file position is+ -- not an error", however e.g. Windows 10 doesn't accept maximum possible+ -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by+ -- trying 2^32-1.+ fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \b -> case b of+ True -> return True+ False -> getLastError >>= \err -> case () of+ () | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False+ | err == #{const ERROR_OPERATION_ABORTED} -> retry+ | otherwise -> failWith ctx err+ where+ sizeof_OVERLAPPED = #{size OVERLAPPED}++ cmode = case mode of+ SharedLock -> 0+ ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}++-- https://msdn.microsoft.com/en-us/library/aa297958.aspx+foreign import ccall unsafe "_get_osfhandle"+ c_get_osfhandle :: CInt -> IO HANDLE++-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx+foreign import WINDOWS_CCONV interruptible "LockFileEx"+ c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL++#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */++lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool+lockImpl h ctx mode block = do+ FD{fdFD = fd} <- handleToFd h+ let flags = cmode .|. (if block then 0 else #{const LOCK_NB})+ fix $ \retry -> c_flock fd flags >>= \n -> case n of+ 0 -> return True+ _ -> getErrno >>= \errno -> case () of+ () | not block && errno == eWOULDBLOCK -> return False+ | errno == eINTR -> retry+ | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing+ where+ cmode = case mode of+ SharedLock -> #{const LOCK_SH}+ ExclusiveLock -> #{const LOCK_EX}++foreign import ccall interruptible "flock"+ c_flock :: CInt -> CInt -> IO CInt++#endif /* !defined(mingw32_HOST_OS) */++-- | Turn an existing Handle into a file descriptor. This function throws an+-- IOError if the Handle does not reference a file descriptor.+handleToFd :: Handle -> IO FD+handleToFd h = case h of+ FileHandle _ mv -> do+ Handle__{haDevice = dev} <- readMVar mv+ case cast dev of+ Just fd -> return fd+ Nothing -> throwErr "not a file descriptor"+ DuplexHandle{} -> throwErr "not a file handle"+ where+ throwErr msg = ioException $ IOError (Just h)+ InappropriateType "handleToFd" msg Nothing Nothing++#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */++#endif /* MIN_VERSION_base */
hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs view
@@ -7,12 +7,14 @@ , timedIO ) where +import Control.Monad (unless) import Control.Exception import Data.Time import System.IO hiding (openTempFile, withFile) import System.IO.Error import Hackage.Security.Util.Path+import Hackage.Security.Util.FileLock (hTryLock, LockMode(ExclusiveLock), FileLockingNotSupported) {------------------------------------------------------------------------------- Miscelleneous@@ -30,22 +32,51 @@ then return Nothing else throwIO e --- | Attempt to create a filesystem lock in the specified directory+-- | Attempt to create a filesystem lock in the specified directory. --+-- This will use OS-specific file locking primitives: "GHC.IO.Handle.Lock" with+-- @base-4.10" and later or a shim for @base@ versions.+--+-- Throws an exception if the lock is already present.+--+-- May fallback to locking via creating a directory: -- Given a file @/path/to@, we do this by attempting to create the directory -- @//path/to/hackage-security-lock@, and deleting the directory again -- afterwards. Creating a directory that already exists will throw an exception -- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way -- to implement a lock file. withDirLock :: Path Absolute -> IO a -> IO a-withDirLock dir = bracket_ takeLock releaseLock+withDirLock dir = bracket takeLock releaseLock . const where lock :: Path Absolute lock = dir </> fragment "hackage-security-lock" - takeLock, releaseLock :: IO ()- takeLock = createDirectory lock- releaseLock = removeDirectory lock+ lock' :: FilePath+ lock' = toFilePath lock++ takeLock = do+ h <- openFile lock' ReadWriteMode+ handle (takeDirLock h) $ do+ gotlock <- hTryLock h ExclusiveLock+ unless gotlock $+ fail $ "hTryLock: lock already exists: " ++ lock'+ return (Just h)++ takeDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle)+ takeDirLock h _ = do+ -- We fallback to directory locking+ -- so we need to cleanup lock file first: close and remove+ hClose h+ handle onIOError (removeFile lock)+ createDirectory lock+ return Nothing++ onIOError :: IOError -> IO ()+ onIOError _ = hPutStrLn stderr+ "withDirLock: cannot remove lock file before directory lock fallback"++ releaseLock (Just h) = hClose h+ releaseLock Nothing = removeDirectory lock {------------------------------------------------------------------------------- Debugging
hackage-security/hackage-security/tests/TestSuite.hs view
@@ -70,6 +70,7 @@ testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical , testProperty "prop_roundtrip_pretty" JSON.prop_roundtrip_pretty , testProperty "prop_canonical_pretty" JSON.prop_canonical_pretty+ , testProperty "prop_aeson_canonical" JSON.prop_aeson_canonical ] ]
hackage-security/hackage-security/tests/TestSuite/JSON.hs view
@@ -3,6 +3,7 @@ prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty,+ prop_aeson_canonical, ) where -- stdlib@@ -16,6 +17,11 @@ -- hackage-security import Text.JSON.Canonical +-- aeson+import Data.Aeson (Value (..), eitherDecode, FromJSON (..))+import Data.String (fromString)+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty :: JSValue -> Bool@@ -30,6 +36,9 @@ parseCanonicalJSON (renderCanonicalJSON jsval) == fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval))) +prop_aeson_canonical jsval =+ eitherDecode (renderCanonicalJSON jsval) == Right (toAeson (canonicalise jsval))+ canonicalise :: JSValue -> JSValue canonicalise v@JSNull = v canonicalise v@(JSBool _) = v@@ -46,12 +55,13 @@ [ (1, pure JSNull) , (1, JSBool <$> arbitrary) , (2, JSNum <$> arbitrary)- , (2, JSString <$> arbitrary)+ , (2, JSString . getASCIIString <$> arbitrary) , (3, JSArray <$> resize (sz `div` 2) arbitrary)- , (3, JSObject . noDupFields <$> resize (sz `div` 2) arbitrary)+ , (3, JSObject . mapFirst getASCIIString . noDupFields <$> resize (sz `div` 2) arbitrary) ] where noDupFields = nubBy (\(x,_) (y,_) -> x==y)+ mapFirst f = map (\(x, y) -> (f x, y)) shrink JSNull = [] shrink (JSBool _) = []@@ -62,6 +72,13 @@ where shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ] +toAeson :: JSValue -> Value+toAeson JSNull = Null+toAeson (JSBool b) = Bool b+toAeson (JSNum n) = Number (fromIntegral n)+toAeson (JSString s) = String (fromString s)+toAeson (JSArray xs) = Array $ V.fromList [ toAeson x | x <- xs ]+toAeson (JSObject xs) = Object $ HM.fromList [ (fromString k, toAeson v) | (k, v) <- xs ] instance Arbitrary Int54 where arbitrary = fromIntegral <$>
hackport.cabal view
@@ -1,5 +1,5 @@ Name: hackport-Version: 0.5.6+Version: 0.6 License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -66,6 +66,7 @@ -- hackage-security DefaultSignatures, DeriveDataTypeable,+ DoAndIfThenElse, EmptyDataDecls, ExistentialQuantification, FlexibleContexts,@@ -126,6 +127,8 @@ Status Merge Util+ -- hsc files+ Hackage.Security.Util.FileLock Test-Suite test-resolve-category ghc-options: -Wall