diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,13 @@ +0.5.1.0 +------- + +* Fix for other local programs corrputing the 00-index.tar. Detect it + and do a full rewrite rather than incremental append. +* New JSON pretty-printer (not canonical rendering) +* Round-trip tests for Canonical JSON parser and printers +* Minor fix for Canonical JSON parser +* Switch from cryptohash to cryptohash-sha256 to avoid new dependencies + 0.5.0.2 ------- * Use tar 0.5.0 diff --git a/hackage-security.cabal b/hackage-security.cabal --- a/hackage-security.cabal +++ b/hackage-security.cabal @@ -1,5 +1,5 @@ name: hackage-security -version: 0.5.0.2 +version: 0.5.1.0 synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server @@ -46,6 +46,11 @@ description: Are we using network-uri? manual: False +Flag old-directory + description: Use directory < 1.2 and old-time + manual: False + default: False + library -- Most functionality is exported through the top-level entry points .Client -- and .Server; the other exported modules are intended for qualified imports. @@ -93,16 +98,18 @@ Prelude -- We support ghc 7.4 (bundled with Cabal 1.14) and up build-depends: base >= 4.5 && < 5, + base16-bytestring >= 0.1.1 && < 0.2, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.9 && < 0.11, - Cabal >= 1.14 && < 1.25, + Cabal >= 1.14 && < 1.26, containers >= 0.4 && < 0.6, directory >= 1.1.0.2 && < 1.3, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, mtl >= 2.2 && < 2.3, parsec >= 3.1 && < 3.2, - cryptohash >= 0.11 && < 0.12, + pretty >= 1.0 && < 1.2, + cryptohash-sha256 >= 0.11 && < 0.12, -- 0.4.2 introduces TarIndex, 0.4.4 introduces more -- functionality, 0.5.0 changes type of serialise tar >= 0.5 && < 0.6, @@ -112,6 +119,10 @@ -- whatever versions are bundled with ghc: template-haskell, ghc-prim + if flag(old-directory) + build-depends: directory < 1.2, old-time >= 1 && < 1.2 + else + build-depends: directory >= 1.2 hs-source-dirs: src default-language: Haskell2010 default-extensions: DefaultSignatures @@ -218,6 +229,8 @@ tar, tasty, tasty-hunit, + tasty-quickcheck, + QuickCheck, temporary, time, zlib diff --git a/src/Hackage/Security/Client/Repository/Cache.hs b/src/Hackage/Security/Client/Repository/Cache.hs --- a/src/Hackage/Security/Client/Repository/Cache.hs +++ b/src/Hackage/Security/Client/Repository/Cache.hs @@ -16,6 +16,7 @@ import Control.Exception import Control.Monad +import Data.Maybe import Codec.Archive.Tar (Entries(..)) import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset) import qualified Codec.Archive.Tar as Tar @@ -58,21 +59,51 @@ downloadedCopyTo downloaded fp -- Whether or not we downloaded the compressed index incrementally, we can - -- always update the uncompressed index incrementally. + -- update the uncompressed index incrementally (assuming the local files + -- have not been corrupted). -- NOTE: This assumes we already updated the compressed file. unzipIndex :: typ ~ Binary => IO () unzipIndex = do createDirectoryIfMissing True (takeDirectory indexUn) - compressed <- readLazyByteString indexGz - let uncompressed = GZip.decompress compressed - withFile indexUn ReadWriteMode $ \h -> do - currentSize <- hFileSize h - let seekTo = 0 `max` (currentSize - tarTrailer) - hSeek h AbsoluteSeek seekTo - BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed + shouldTryIncremenal <- cachedIndexProbablyValid + if shouldTryIncremenal + then unzipIncremenal + else unzipNonIncremenal where - indexGz = cachedIndexPath cache FGz - indexUn = cachedIndexPath cache FUn + unzipIncremenal = do + compressed <- readLazyByteString indexGz + let uncompressed = GZip.decompress compressed + withFile indexUn ReadWriteMode $ \h -> do + currentSize <- hFileSize h + let seekTo = 0 `max` (currentSize - tarTrailer) + hSeek h AbsoluteSeek seekTo + BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed + + unzipNonIncremenal = do + compressed <- readLazyByteString indexGz + let uncompressed = GZip.decompress compressed + withFile indexUn WriteMode $ \h -> + BS.L.hPut h uncompressed + void . handleDoesNotExist $ + removeFile indexIdx -- Force a full rebuild of the index too + + -- When we update the 00-index.tar we also update the 00-index.tar.idx + -- so the expected state is that the modification time for the tar.idx + -- is the same or later than the .tar file. But if someone modified + -- the 00-index.tar then the modification times will be reversed. So, + -- if the modification times are reversed then we should not do an + -- incremental update but should rewrite the whole file. + cachedIndexProbablyValid :: IO Bool + cachedIndexProbablyValid = + fmap (fromMaybe False) $ + handleDoesNotExist $ do + tsUn <- getModificationTime indexUn + tsIdx <- getModificationTime indexIdx + return (tsIdx >= tsUn) + + indexGz = cachedIndexPath cache FGz + indexUn = cachedIndexPath cache FUn + indexIdx = cachedIndexIdxPath cache tarTrailer :: Integer tarTrailer = 1024 diff --git a/src/Hackage/Security/Key.hs b/src/Hackage/Security/Key.hs --- a/src/Hackage/Security/Key.hs +++ b/src/Hackage/Security/Key.hs @@ -29,9 +29,11 @@ import Data.Functor.Identity import Data.Typeable (Typeable) import Text.JSON.Canonical -import qualified Crypto.Hash as CH +import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Sign.Ed25519 as Ed25519 import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.C8 +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BS.L #if !MIN_VERSION_base(4,7,0) @@ -159,8 +161,9 @@ instance HasKeyId PublicKey where keyId = KeyId - . show - . (CH.hashlazy :: BS.L.ByteString -> CH.Digest CH.SHA256) + . BS.C8.unpack + . Base16.encode + . SHA256.hashlazy . renderCanonicalJSON . runIdentity . toJSON diff --git a/src/Hackage/Security/TUF/FileInfo.hs b/src/Hackage/Security/TUF/FileInfo.hs --- a/src/Hackage/Security/TUF/FileInfo.hs +++ b/src/Hackage/Security/TUF/FileInfo.hs @@ -14,9 +14,11 @@ import Prelude hiding (lookup) import Data.Map (Map) -import qualified Crypto.Hash as CH +import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.Map as Map +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BS.L +import qualified Data.ByteString.Char8 as BS.C8 import Hackage.Security.JSON import Hackage.Security.TUF.Common @@ -58,7 +60,7 @@ fileInfo bs = FileInfo { fileInfoLength = FileLength . fromIntegral $ BS.L.length bs , fileInfoHashes = Map.fromList [ - (HashFnSHA256, Hash $ show (CH.hashlazy bs :: CH.Digest CH.SHA256)) + (HashFnSHA256, Hash $ BS.C8.unpack $ Base16.encode $ SHA256.hashlazy bs) ] } diff --git a/src/Hackage/Security/Util/Path.hs b/src/Hackage/Security/Util/Path.hs --- a/src/Hackage/Security/Util/Path.hs +++ b/src/Hackage/Security/Util/Path.hs @@ -53,6 +53,7 @@ , removeDirectory , doesFileExist , doesDirectoryExist + , getModificationTime , removeFile , getTemporaryDirectory , getDirectoryContents @@ -84,6 +85,11 @@ import Data.List (isPrefixOf) import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..)) import System.IO.Unsafe (unsafeInterleaveIO) +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime) +#else +import System.Time (ClockTime) +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L import qualified System.FilePath as FP @@ -330,6 +336,15 @@ doesDirectoryExist path = do filePath <- toAbsoluteFilePath path Dir.doesDirectoryExist filePath + +#if MIN_VERSION_directory(1,2,0) +getModificationTime :: FsRoot root => Path root -> IO UTCTime +#else +getModificationTime :: FsRoot root => Path root -> IO ClockTime +#endif +getModificationTime path = do + filePath <- toAbsoluteFilePath path + Dir.getModificationTime filePath removeFile :: FsRoot root => Path root -> IO () removeFile path = do diff --git a/src/Text/JSON/Canonical.hs b/src/Text/JSON/Canonical.hs --- a/src/Text/JSON/Canonical.hs +++ b/src/Text/JSON/Canonical.hs @@ -9,7 +9,7 @@ -- -- -- --- A "canonical JSON" format is provided in order to provide meaningful and +-- A \"canonical JSON\" format is provided in order to provide meaningful and -- repeatable hashes of JSON-encoded data. Canonical JSON is parsable with any -- full JSON parser, but security-conscious applications will want to verify -- that input is in canonical form before authenticating any hash or signature @@ -27,12 +27,18 @@ , Int54 , parseCanonicalJSON , renderCanonicalJSON + , prettyCanonicalJSON ) where import Text.ParserCombinators.Parsec ( CharParser, (<|>), (), many, between, sepBy , satisfy, char, string, digit, spaces , parse ) +import Text.PrettyPrint hiding (char) +import qualified Text.PrettyPrint as Doc +#if !(MIN_VERSION_base(4,7,0)) +import Control.Applicative ((<$>), (<$), pure, (<*>), (<*), (*>)) +#endif import Control.Arrow (first) import Data.Bits (Bits) #if MIN_VERSION_base(4,7,0) @@ -68,8 +74,7 @@ -- probably define `fromInteger` to do bounds checking, give different instances -- for type classes such as `Bounded` and `FiniteBits`, etc. newtype Int54 = Int54 { int54ToInt64 :: Int64 } - deriving ( Bounded - , Enum + deriving ( Enum , Eq , Integral , Data @@ -86,6 +91,10 @@ , Typeable ) +instance Bounded Int54 where + maxBound = Int54 ( 2^(53 :: Int) - 1) + minBound = Int54 (-(2^(53 :: Int) - 1)) + instance Show Int54 where show = show . int54ToInt64 @@ -93,9 +102,14 @@ readsPrec p = map (first Int54) . readsPrec p ------------------------------------------------------------------------------ +-- rendering flat +-- --- | Encode as \"Canonical\" JSON. +-- | Render a JSON value in canonical form. This rendered form is canonical +-- and so allows repeatable hashes. -- +-- For pretty printing, see prettyCanonicalJSON. +-- -- NB: Canonical JSON's string escaping rules deviate from RFC 7159 -- JSON which requires -- @@ -111,6 +125,7 @@ -- parser" -- -- Consequently, Canonical JSON is not a proper subset of RFC 7159. +-- renderCanonicalJSON :: JSValue -> BS.ByteString renderCanonicalJSON v = BS.pack (s_value v []) @@ -149,7 +164,15 @@ . showl kvs ------------------------------------------------------------------------------ +-- parsing +-- +-- | Parse a canonical JSON format string as a JSON value. The input string +-- does not have to be in canonical form, just in the \"canonical JSON\" +-- format. +-- +-- Use 'renderCanonicalJSON' to convert into canonical form. +-- parseCanonicalJSON :: BS.ByteString -> Either String JSValue parseCanonicalJSON = either (Left . show) Right . parse p_value "" @@ -213,7 +236,7 @@ \" -} p_string :: CharParser () String -p_string = between (tok (char '"')) (tok (char '"')) (many p_char) +p_string = between (char '"') (tok (char '"')) (many p_char) where p_char = (char '\\' >> p_esc) <|> (satisfy (\x -> x /= '"' && x /= '\\')) @@ -270,3 +293,63 @@ manyN 0 _ = pure [] manyN n p = ((:) <$> p <*> manyN (n-1) p) <|> pure [] + +------------------------------------------------------------------------------ +-- rendering nicely +-- + +-- | Render a JSON value in a reasonable human-readable form. This rendered +-- form is /not the canonical form/ used for repeatable hashes, use +-- 'renderCanonicalJSON' for that. + +-- It is suitable however as an external form as any canonical JSON parser can +-- read it and convert it into the form used for repeatable hashes. +-- +prettyCanonicalJSON :: JSValue -> String +prettyCanonicalJSON = render . jvalue + +jvalue :: JSValue -> Doc +jvalue JSNull = text "null" +jvalue (JSBool False) = text "false" +jvalue (JSBool True) = text "true" +jvalue (JSNum n) = integer (fromIntegral (int54ToInt64 n)) +jvalue (JSString s) = jstring s +jvalue (JSArray vs) = jarray vs +jvalue (JSObject fs) = jobject fs + +jstring :: String -> Doc +jstring = doubleQuotes . hcat . map jchar + +jchar :: Char -> Doc +jchar '"' = Doc.char '\\' <> Doc.char '"' +jchar '\\' = Doc.char '\\' <> Doc.char '\\' +jchar c = Doc.char c + +jarray :: [JSValue] -> Doc +jarray = sep . punctuate' lbrack comma rbrack + . map jvalue + +jobject :: [(String, JSValue)] -> Doc +jobject = sep . punctuate' lbrace comma rbrace + . map (\(k,v) -> sep [jstring k <> colon, nest 2 (jvalue v)]) + + +-- | Punctuate in this style: +-- +-- > [ foo, bar ] +-- +-- if it fits, or vertically otherwise: +-- +-- > [ foo +-- > , bar +-- > ] +-- +punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc] +punctuate' l _ r [] = [l <> r] +punctuate' l _ r [x] = [l <+> x <+> r] +punctuate' l p r (x:xs) = l <+> x : go xs + where + go [] = [] + go [y] = [p <+> y, r] + go (y:ys) = (p <+> y) : go ys + diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -8,6 +8,7 @@ import Network.URI (URI, parseURI) import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import System.IO.Temp (withSystemTempDirectory) -- hackage-security @@ -27,6 +28,7 @@ import TestSuite.InMemRepository import TestSuite.PrivateKeys import TestSuite.Util.StrictMVar +import TestSuite.JSON as JSON {------------------------------------------------------------------------------- TestSuite driver @@ -50,6 +52,11 @@ , testCase "testHttpMemUpdatesAfterCron" testHttpMemUpdatesAfterCron , testCase "testHttpMemKeyRollover" testHttpMemKeyRollover , testCase "testHttpMemOutdatedTimestamp" testHttpMemOutdatedTimestamp + ] + , testGroup "Canonical JSON" [ + testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical + , testProperty "prop_roundtrip_pretty" JSON.prop_roundtrip_pretty + , testProperty "prop_canonical_pretty" JSON.prop_canonical_pretty ] ]