Package.hs (13909B)
1 -- Exact-version registry policy. Compilation never imports this module. 2 module Package 3 ( Release(..), PackageLock(..), encodeRelease, decodeRelease 4 , encodeLock, decodeLock, validComponent, validateRegistryURL 5 , publishRelease, resolveRelease, fetchLocked, bindLocked 6 , readSmall, readRegistries, writeAtomic, distinctFiles 7 , resolveSelection, fetchSelection, verifyLocal, bindingBytes 8 ) where 9 10 import ContentStore.Object 11 import ContentStore.Alias (ObjectRef(..)) 12 import ContentStore.Bundle 13 import Module.Manifest 14 import Control.Exception (IOException, bracket, catch) 15 import Control.Monad (unless, when, forM_) 16 import Crypto.Hash (hash, Digest, SHA256) 17 import qualified Data.ByteString as BS 18 import qualified Data.Text as T 19 import Data.Text (Text) 20 import Data.Text.Encoding (encodeUtf8, decodeUtf8') 21 import qualified Data.Set as Set 22 import Network.HTTP.Client hiding (path) 23 import Network.HTTP.Client.TLS (tlsManagerSettings) 24 import Network.HTTP.Types.Status (statusCode) 25 import Network.URI (parseURI, URI(..), URIAuth(..)) 26 import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile, canonicalizePath) 27 import System.FilePath ((</>), takeDirectory) 28 import System.IO (openBinaryTempFile, hClose) 29 import qualified System.IO 30 import System.IO.Error (isAlreadyExistsError) 31 import System.IO.Temp (withSystemTempDirectory) 32 import System.Posix.Files (createLink) 33 import System.Posix.IO (openFd, closeFd, defaultFileFlags, OpenMode(ReadOnly)) 34 import System.Posix.Unistd (fileSynchronise) 35 import System.Timeout (timeout) 36 37 -- v1 deliberately denotes one native module, not a general package graph. 38 data Release = Release 39 { releaseName :: Text, releaseVersion :: Text 40 , releaseManifest :: Text, releaseBundle :: Text 41 } deriving (Eq, Show) 42 data PackageLock = PackageLock 43 { lockRegistry :: Text, lockURL :: Text, lockRelease :: Release 44 } deriving (Eq, Show) 45 46 validComponent :: Text -> Bool 47 validComponent s = not (T.null s) && T.length s <= 128 48 && asciiAlphaNum (T.head s) && T.all (\c -> asciiAlphaNum c || c `elem` ("._-" :: String)) s 49 where asciiAlphaNum c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') 50 51 validateRelease :: Release -> Either String () 52 validateRelease r = do 53 unless (validComponent (releaseName r) && validComponent (releaseVersion r)) $ 54 Left "invalid package name/version (1-128 ASCII letters/digits/._-, starting with letter/digit)" 55 validateObjectHash (releaseManifest r) 56 validateObjectHash (releaseBundle r) 57 58 releaseRow :: Release -> Text 59 releaseRow r = T.intercalate "\t" [releaseName r, releaseVersion r, releaseManifest r, releaseBundle r] 60 encodeRelease :: Release -> BS.ByteString 61 encodeRelease r = encodeUtf8 $ "arboricx.package-release.v1\n" <> releaseRow r <> "\n" 62 parseReleaseRow :: Text -> Either String Release 63 parseReleaseRow row = case T.splitOn "\t" row of 64 [n,v,m,b] -> let r = Release n v m b in validateRelease r >> Right r 65 _ -> Left "invalid package release row" 66 decodeRelease :: BS.ByteString -> Either String Release 67 decodeRelease bytes = do 68 txt <- either (Left . show) Right (decodeUtf8' bytes) 69 r <- case T.lines txt of 70 ["arboricx.package-release.v1", row] -> parseReleaseRow row 71 _ -> Left "unsupported package release format" 72 unless (encodeRelease r == bytes) $ Left "noncanonical package release" 73 pure r 74 75 -- Origin-only URLs: no userinfo, paths, queries, fragments or implicit redirects. 76 -- HTTP is allowed only for literal loopback development origins. 77 validateRegistryURL :: Text -> Either String () 78 validateRegistryURL url = case parseURI (T.unpack url) of 79 Just u | Just a <- uriAuthority u 80 , null (uriUserInfo a), not (null (uriRegName a)) 81 , null (uriPath u), null (uriQuery u), null (uriFragment u) 82 , all (\c -> c > ' ' && c < '\127') (T.unpack url) 83 , uriScheme u == "https:" || (uriScheme u == "http:" && uriRegName a `elem` ["localhost", "127.0.0.1", "[::1]"]) 84 -> Right () 85 _ -> Left "registry URL must be an HTTPS origin without trailing slash (HTTP only for loopback)" 86 87 encodeLock :: PackageLock -> BS.ByteString 88 encodeLock l = encodeUtf8 $ "arboricx.package-lock.v1\n" <> lockRegistry l <> "\t" <> lockURL l <> "\n" <> releaseRow (lockRelease l) <> "\n" 89 decodeLock :: BS.ByteString -> Either String PackageLock 90 decodeLock bytes = do 91 txt <- either (Left . show) Right (decodeUtf8' bytes) 92 l <- case T.lines txt of 93 ["arboricx.package-lock.v1", origin, row] -> case T.splitOn "\t" origin of 94 [name,url] -> do 95 unless (validComponent name) $ Left "invalid registry name" 96 validateRegistryURL url 97 PackageLock name url <$> parseReleaseRow row 98 _ -> Left "invalid lock origin" 99 _ -> Left "unsupported package lock format" 100 unless (encodeLock l == bytes) $ Left "noncanonical package lock" 101 pure l 102 103 readSmall :: FilePath -> IO BS.ByteString 104 readSmall path = do 105 -- Metadata is tiny; cap reads, including untrusted lock/config files. 106 bracket (System.IO.openBinaryFile path System.IO.ReadMode) hClose $ \h -> do 107 bytes <- BS.hGet h 65537 108 when (BS.length bytes > 65536) $ fail "metadata exceeds 64 KiB" 109 pure bytes 110 111 registryURL :: FilePath -> Text -> IO Text 112 registryURL config selected = do 113 entries <- readRegistries config 114 maybe (fail "registry is not explicitly trusted in configuration") pure (lookup selected entries) 115 116 readRegistries :: FilePath -> IO [(Text, Text)] 117 readRegistries config = do 118 bytes <- readSmall config 119 txt <- either (fail . show) pure (decodeUtf8' bytes) 120 rows <- case T.lines txt of 121 "arboricx.registries.v1" : rest -> pure rest 122 _ -> fail "unsupported registry configuration" 123 entries <- mapM (\row -> case T.splitOn "\t" row of 124 [name,url] | validComponent name -> either fail pure (validateRegistryURL url) >> pure (name,url) 125 _ -> fail "invalid registry configuration row") rows 126 unless (Set.size (Set.fromList (map fst entries)) == length entries) $ fail "duplicate registry name" 127 pure entries 128 129 syncPath :: FilePath -> IO () 130 syncPath path = bracket (openFd path ReadOnly defaultFileFlags) closeFd fileSynchronise 131 132 -- Trusted directories only. No-replace handles concurrent publishers, checking 133 -- the winner byte-for-byte; mutable locks/bindings use explicit atomic replacement. 134 writeAtomic :: Bool -> FilePath -> BS.ByteString -> IO () 135 writeAtomic exclusive path bytes = do 136 createDirectoryIfMissing True (takeDirectory path) 137 bracket (openBinaryTempFile (takeDirectory path) ".package-") 138 (\(tmp,h) -> do 139 hClose h `catch` (\(_ :: IOException) -> pure ()) 140 removeFile tmp `catch` (\(_ :: IOException) -> pure ())) $ \(tmp,h) -> do 141 BS.hPut h bytes 142 hClose h 143 syncPath tmp 144 if exclusive then createLink tmp path `catch` (\e -> 145 if isAlreadyExistsError e then do 146 existing <- BS.readFile path 147 unless (existing == bytes) $ fail "immutable publication conflict" 148 syncPath path 149 else ioError e) 150 else renameFile tmp path 151 syncPath (takeDirectory path) 152 153 bundleDigest :: BS.ByteString -> Text 154 bundleDigest bytes = hashToText (hash bytes :: Digest SHA256) 155 156 -- Match the native reader's ASCII source-name profile before advertising a 157 -- release. Import writes immutable objects only, never ambient aliases. 158 importModule :: StorePath -> BS.ByteString -> IO Text 159 importModule store bytes = do 160 roots <- unpackIndexedBundleToStore store bytes 161 unless (not (null roots) && all (validExport . fst) roots) $ fail "package requires a nonempty native module interface" 162 putManifest store (ModuleManifest [] 163 [ModuleExport name (ObjectRef (unDomain indexedTreeDomain) digest) "arboricx.abi.tree.v1" | (name,digest) <- roots]) 164 where 165 validExport n = case T.uncons n of 166 Just (c,rest) -> start c && T.all (\x -> start x || (x >= '0' && x <= '9') || x `elem` ("-?$%'." :: String)) rest 167 _ -> False 168 start c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c == '_' 169 170 publishRelease :: FilePath -> Text -> Text -> FilePath -> IO Release 171 publishRelease root name version bundleFile = do 172 unless (validComponent name && validComponent version) $ fail "invalid package name/version" 173 bytes <- bracket (System.IO.openBinaryFile bundleFile System.IO.ReadMode) hClose $ \h -> BS.hGet h (bundleLimit + 1) 174 when (BS.length bytes > bundleLimit) $ fail "bundle exceeds 64 MiB transport limit" 175 manifest <- withSystemTempDirectory "tricu-package" $ \tmp -> importModule (StorePath tmp) bytes 176 let digest = bundleDigest bytes 177 r = Release name version manifest digest 178 writeAtomic True (root </> "objects" </> T.unpack (T.take 3 digest) </> T.unpack digest ++ ".arboricx") bytes 179 writeAtomic True (root </> "packages" </> T.unpack name </> T.unpack version) (encodeRelease r) 180 pure r 181 182 bundleLimit :: Int 183 bundleLimit = 64 * 1024 * 1024 184 185 getBounded :: Text -> Int -> IO BS.ByteString 186 getBounded url limit = requestBytes `catch` (\(e :: HttpException) -> fail (show e)) 187 where 188 requestBytes = do 189 reply <- timeout (60 * 1000000) $ bracket (newManager tlsManagerSettings) closeManager $ \manager -> do 190 initial <- parseRequest (T.unpack url) 191 let request = initial { redirectCount = 0, responseTimeout = responseTimeoutMicro (30 * 1000000) 192 , decompress = const False } 193 withResponse request manager $ \response -> do 194 unless (statusCode (responseStatus response) == 200) $ fail "registry returned non-200 status (redirects are not followed)" 195 let loop n chunks = do 196 chunk <- brRead (responseBody response) 197 let total = n + BS.length chunk 198 when (total > limit) $ fail "registry response exceeds size limit" 199 if BS.null chunk then pure (BS.concat (reverse chunks)) else loop total (chunk:chunks) 200 loop 0 [] 201 maybe (fail "registry request deadline exceeded") pure reply 202 203 resolveRelease :: FilePath -> Text -> Text -> Text -> FilePath -> Bool -> IO PackageLock 204 resolveRelease config registry name version path update = do 205 distinctFiles config path 206 unless (validComponent name && validComponent version) $ fail "invalid package name/version" 207 url <- registryURL config registry 208 exists <- doesFileExist path 209 old <- if exists then Just <$> (readSmall path >>= either fail pure . decodeLock) else pure Nothing 210 l <- resolveSelection registry url name version 211 case old of 212 Just previous | previous /= l -> do 213 let p = lockRelease previous 214 when (lockRegistry previous == registry && lockURL previous == url && releaseName p == name && releaseVersion p == version) $ 215 fail "published version changed; refusing registry equivocation" 216 unless update $ fail "lock selection changed; explicit --update required" 217 _ -> pure () 218 writeAtomic (not exists) path (encodeLock l) 219 pure l 220 221 -- Parsed selections let project operations share transport/verification policy 222 -- without manufacturing temporary single-package lock files. 223 resolveSelection :: Text -> Text -> Text -> Text -> IO PackageLock 224 resolveSelection registry url name version = do 225 unless (validComponent registry && validComponent name && validComponent version) $ fail "invalid registry/package/version" 226 either fail pure (validateRegistryURL url) 227 r <- getBounded (url <> "/_arboricx/package/" <> name <> "/" <> version) 4096 >>= either fail pure . decodeRelease 228 unless (releaseName r == name && releaseVersion r == version) $ fail "registry returned a different package/version" 229 pure (PackageLock registry url r) 230 231 verifyLocal :: StorePath -> Release -> IO Bool 232 verifyLocal store r = do 233 found <- getManifest store (releaseManifest r) 234 case found of 235 Nothing -> pure False 236 Just m -> do 237 unless (null (moduleManifestReferences m) && not (null (moduleManifestExports m))) $ fail "unsupported package module profile" 238 forM_ (moduleManifestExports m) $ \ex -> do 239 unless (objectRefKind (moduleExportObject ex) == unDomain indexedTreeDomain && moduleExportAbi ex == "arboricx.abi.tree.v1") $ fail "unsupported package executable" 240 _ <- loadExecutableObject store (moduleExportObject ex) 241 pure () 242 pure True 243 244 fetchLocked :: FilePath -> FilePath -> StorePath -> IO PackageLock 245 fetchLocked config path store = do 246 l <- readSmall path >>= either fail pure . decodeLock 247 url <- registryURL config (lockRegistry l) 248 fetchSelection url l store 249 pure l 250 251 fetchSelection :: Text -> PackageLock -> StorePath -> IO () 252 fetchSelection url l store = do 253 unless (url == lockURL l) $ fail "configured registry origin differs from lock" 254 let r = lockRelease l 255 present <- verifyLocal store r 256 unless present $ do 257 bytes <- getBounded (url <> "/_arboricx/bundle/hash/" <> releaseBundle r) bundleLimit 258 unless (bundleDigest bytes == releaseBundle r) $ fail "bundle digest mismatch" 259 -- Check the promised module before importing anything into the target store. 260 actual <- withSystemTempDirectory "tricu-package-check" $ \tmp -> importModule (StorePath tmp) bytes 261 unless (actual == releaseManifest r) $ fail "bundle module manifest mismatch" 262 _ <- importModule store bytes 263 pure () 264 265 bindingBytes :: Text -> BS.ByteString 266 bindingBytes manifest = encodeUtf8 ("!export * from " <> manifest <> "\n") 267 268 bindLocked :: FilePath -> StorePath -> FilePath -> IO () 269 bindLocked path store output = do 270 distinctFiles path output 271 l <- readSmall path >>= either fail pure . decodeLock 272 present <- verifyLocal store (lockRelease l) 273 unless present $ fail "locked module missing; fetch it explicitly first" 274 writeAtomic False output (bindingBytes (releaseManifest (lockRelease l))) 275 276 -- Output commands may replace their explicit destination, never their input. 277 distinctFiles :: FilePath -> FilePath -> IO () 278 distinctFiles input output = do 279 source <- canonicalizePath input 280 target <- canonicalizePath output 281 when (source == target) $ fail "output must not replace its input"