321 lines
11 KiB
Text
321 lines
11 KiB
Text
|
#r "System.Formats.Tar"
|
||
|
|
#r "/opt/fsi/packages/ZstdSharp.dll"
|
||
|
|
|
||
|
|
open System
|
||
|
|
open System.Collections.Generic
|
||
|
|
open System.Diagnostics
|
||
|
|
open System.Formats.Tar
|
||
|
|
open System.IO
|
||
|
|
open System.IO.Compression
|
||
|
|
open System.Net.Security
|
||
|
|
open System.Runtime.InteropServices
|
||
|
|
open System.Security.Cryptography
|
||
|
|
open System.Security.Cryptography.X509Certificates
|
||
|
|
open System.Text.Json
|
||
|
|
open System.Text.Json.Serialization
|
||
|
|
open System.Threading
|
||
|
|
open System.Threading.Tasks
|
||
|
|
open ZstdSharp
|
||
|
|
open ZstdSharp.Unsafe
|
||
|
|
|
||
|
|
[<CLIMutable>]
|
||
|
|
type Target =
|
||
|
|
{ [<JsonPropertyName("kind")>]
|
||
|
|
Kind: string
|
||
|
|
[<JsonPropertyName("repository")>]
|
||
|
|
Repository: string }
|
||
|
|
|
||
|
|
[<CLIMutable>]
|
||
|
|
type Published =
|
||
|
|
{ [<JsonPropertyName("kind")>]
|
||
|
|
Kind: string
|
||
|
|
[<JsonPropertyName("repository")>]
|
||
|
|
Repository: string
|
||
|
|
[<JsonPropertyName("reference")>]
|
||
|
|
Reference: string }
|
||
|
|
|
||
|
|
[<CLIMutable>]
|
||
|
|
type Delivery =
|
||
|
|
{ [<JsonPropertyName("sourceRevision")>]
|
||
|
|
SourceRevision: string
|
||
|
|
[<JsonPropertyName("targets")>]
|
||
|
|
Targets: Published array }
|
||
|
|
|
||
|
|
type ProcessResult =
|
||
|
|
{ Code: int
|
||
|
|
Error: string
|
||
|
|
Output: string }
|
||
|
|
|
||
|
|
let json =
|
||
|
|
JsonSerializerOptions(
|
||
|
|
PropertyNamingPolicy = null,
|
||
|
|
WriteIndented = false,
|
||
|
|
DefaultIgnoreCondition = JsonIgnoreCondition.WhenWritingNull
|
||
|
|
)
|
||
|
|
|
||
|
|
let private stopping = new CancellationTokenSource()
|
||
|
|
let mutable private signalExitCode = 143
|
||
|
|
|
||
|
|
let private registerSignal signal exitCode =
|
||
|
|
PosixSignalRegistration.Create(
|
||
|
|
signal,
|
||
|
|
fun context ->
|
||
|
|
context.Cancel <- true
|
||
|
|
signalExitCode <- exitCode
|
||
|
|
stopping.Cancel()
|
||
|
|
)
|
||
|
|
|
||
|
|
let private interrupt = registerSignal PosixSignal.SIGINT 130
|
||
|
|
let private terminate = registerSignal PosixSignal.SIGTERM 143
|
||
|
|
let cancellationToken = stopping.Token
|
||
|
|
|
||
|
|
let private exitForSignal<'T> () =
|
||
|
|
Environment.Exit signalExitCode
|
||
|
|
Unchecked.defaultof<'T>
|
||
|
|
|
||
|
|
let fail message = invalidOp message
|
||
|
|
|
||
|
|
let require valid message =
|
||
|
|
if not valid then
|
||
|
|
fail message
|
||
|
|
|
||
|
|
let directory (path: string) =
|
||
|
|
Directory.CreateDirectory path |> ignore
|
||
|
|
path
|
||
|
|
|
||
|
|
let sha256 (path: string) =
|
||
|
|
use input = File.OpenRead path
|
||
|
|
Convert.ToHexString(SHA256.HashData input).ToLowerInvariant()
|
||
|
|
|
||
|
|
let hashText (value: string) =
|
||
|
|
value
|
||
|
|
|> Text.Encoding.UTF8.GetBytes
|
||
|
|
|> SHA256.HashData
|
||
|
|
|> Convert.ToHexString
|
||
|
|
|> _.ToLowerInvariant()
|
||
|
|
|
||
|
|
let validRevision (value: string) =
|
||
|
|
not <| isNull value
|
||
|
|
&& (value.Length = 40 || value.Length = 64)
|
||
|
|
&& value
|
||
|
|
|> Seq.forall (fun character -> Char.IsAsciiHexDigit character && not <| Char.IsUpper character)
|
||
|
|
|
||
|
|
let validSha256 (value: string) =
|
||
|
|
not <| isNull value
|
||
|
|
&& value.Length = 64
|
||
|
|
&& value
|
||
|
|
|> Seq.forall (fun character -> Char.IsAsciiHexDigit character && not <| Char.IsUpper character)
|
||
|
|
|
||
|
|
let validDigest (value: string) =
|
||
|
|
not <| isNull value
|
||
|
|
&& value.StartsWith("sha256:", StringComparison.Ordinal)
|
||
|
|
&& validSha256 value[7..]
|
||
|
|
|
||
|
|
let decode<'T> (value: string) =
|
||
|
|
let result = JsonSerializer.Deserialize<'T>(value, json)
|
||
|
|
require (not <| isNull (box result)) "JSON document is missing"
|
||
|
|
result
|
||
|
|
|
||
|
|
let sleep (milliseconds: int) =
|
||
|
|
try
|
||
|
|
Task.Delay(milliseconds, cancellationToken).GetAwaiter().GetResult()
|
||
|
|
with :? OperationCanceledException when cancellationToken.IsCancellationRequested ->
|
||
|
|
exitForSignal ()
|
||
|
|
|
||
|
|
let run
|
||
|
|
(executable: string)
|
||
|
|
(arguments: string seq)
|
||
|
|
(workingDirectory: string option)
|
||
|
|
(environment: (string * string) seq)
|
||
|
|
=
|
||
|
|
let start = ProcessStartInfo executable
|
||
|
|
start.UseShellExecute <- false
|
||
|
|
start.RedirectStandardOutput <- true
|
||
|
|
start.RedirectStandardError <- true
|
||
|
|
|
||
|
|
workingDirectory |> Option.iter (fun path -> start.WorkingDirectory <- path)
|
||
|
|
arguments |> Seq.iter start.ArgumentList.Add
|
||
|
|
environment |> Seq.iter (fun (name, value) -> start.Environment[name] <- value)
|
||
|
|
|
||
|
|
use child = Process.Start start
|
||
|
|
let output = child.StandardOutput.ReadToEndAsync()
|
||
|
|
let error = child.StandardError.ReadToEndAsync()
|
||
|
|
|
||
|
|
try
|
||
|
|
child.WaitForExitAsync(cancellationToken).GetAwaiter().GetResult()
|
||
|
|
with :? OperationCanceledException when cancellationToken.IsCancellationRequested ->
|
||
|
|
if not child.HasExited then
|
||
|
|
child.Kill true
|
||
|
|
child.WaitForExit()
|
||
|
|
|
||
|
|
exitForSignal ()
|
||
|
|
|
||
|
|
{ Code = child.ExitCode
|
||
|
|
Error = error.GetAwaiter().GetResult()
|
||
|
|
Output = output.GetAwaiter().GetResult() }
|
||
|
|
|
||
|
|
let requireSuccess executable arguments workingDirectory environment =
|
||
|
|
let result = run executable arguments workingDirectory environment
|
||
|
|
require (result.Code = 0) $"{Path.GetFileName executable} failed: {result.Error.Trim()}"
|
||
|
|
result.Output
|
||
|
|
|
||
|
|
let private descendants (root: string) =
|
||
|
|
seq {
|
||
|
|
let pending = Stack<string>(Directory.EnumerateFileSystemEntries root)
|
||
|
|
|
||
|
|
while pending.Count > 0 do
|
||
|
|
let path = pending.Pop()
|
||
|
|
yield path
|
||
|
|
|
||
|
|
let attributes = File.GetAttributes path
|
||
|
|
|
||
|
|
if
|
||
|
|
attributes.HasFlag FileAttributes.Directory
|
||
|
|
&& not (attributes.HasFlag FileAttributes.ReparsePoint)
|
||
|
|
then
|
||
|
|
Directory.EnumerateFileSystemEntries path |> Seq.iter pending.Push
|
||
|
|
}
|
||
|
|
|
||
|
|
let private tree (root: string) =
|
||
|
|
seq {
|
||
|
|
yield root
|
||
|
|
|
||
|
|
if Directory.Exists root then
|
||
|
|
yield! descendants root
|
||
|
|
}
|
||
|
|
|
||
|
|
let private safePath (root: string) (name: string) =
|
||
|
|
require (not <| Path.IsPathFullyQualified name) "archive path is absolute"
|
||
|
|
let path = Path.GetFullPath(Path.Combine(root, name))
|
||
|
|
let prefix = root + string Path.DirectorySeparatorChar
|
||
|
|
require (path = root || path.StartsWith(prefix, StringComparison.Ordinal)) "archive path escapes destination"
|
||
|
|
path
|
||
|
|
|
||
|
|
let private extract (input: Stream) (destination: string) =
|
||
|
|
let root = Path.GetFullPath destination
|
||
|
|
directory root |> ignore
|
||
|
|
let directoryModes = ResizeArray<string * UnixFileMode>()
|
||
|
|
use reader = new TarReader(input, leaveOpen = false)
|
||
|
|
|
||
|
|
for entry in
|
||
|
|
Seq.initInfinite (fun _ -> reader.GetNextEntry())
|
||
|
|
|> Seq.takeWhile (isNull >> not) do
|
||
|
|
let path = safePath root entry.Name
|
||
|
|
|
||
|
|
match entry.EntryType with
|
||
|
|
| TarEntryType.Directory ->
|
||
|
|
directory path |> ignore
|
||
|
|
directoryModes.Add(path, entry.Mode)
|
||
|
|
| TarEntryType.RegularFile
|
||
|
|
| TarEntryType.V7RegularFile
|
||
|
|
| TarEntryType.ContiguousFile ->
|
||
|
|
directory (Path.GetDirectoryName path) |> ignore
|
||
|
|
use output = File.Create path
|
||
|
|
|
||
|
|
if not <| isNull entry.DataStream then
|
||
|
|
entry.DataStream.CopyTo output
|
||
|
|
|
||
|
|
output.Dispose()
|
||
|
|
File.SetUnixFileMode(path, entry.Mode)
|
||
|
|
| TarEntryType.SymbolicLink ->
|
||
|
|
require (not <| Path.IsPathFullyQualified entry.LinkName) "archive link is absolute"
|
||
|
|
|
||
|
|
let target =
|
||
|
|
Path.GetFullPath(Path.Combine(Path.GetDirectoryName path, entry.LinkName))
|
||
|
|
|
||
|
|
let prefix = root + string Path.DirectorySeparatorChar
|
||
|
|
|
||
|
|
require
|
||
|
|
(target = root || target.StartsWith(prefix, StringComparison.Ordinal))
|
||
|
|
"archive link escapes destination"
|
||
|
|
|
||
|
|
directory (Path.GetDirectoryName path) |> ignore
|
||
|
|
File.CreateSymbolicLink(path, entry.LinkName) |> ignore
|
||
|
|
| TarEntryType.GlobalExtendedAttributes -> ()
|
||
|
|
| _ -> fail $"unsupported archive entry: {entry.Name}"
|
||
|
|
|
||
|
|
directoryModes
|
||
|
|
|> Seq.sortByDescending (fun (path, _) -> path.Length)
|
||
|
|
|> Seq.iter File.SetUnixFileMode
|
||
|
|
|
||
|
|
let extractGzip (source: string) (destination: string) =
|
||
|
|
use input = File.OpenRead source
|
||
|
|
use gzip = new GZipStream(input, CompressionMode.Decompress)
|
||
|
|
extract gzip destination
|
||
|
|
|
||
|
|
let extractZstd (source: string) (destination: string) =
|
||
|
|
use input = File.OpenRead source
|
||
|
|
use zstd = new DecompressionStream(input, 131072, false, false)
|
||
|
|
extract zstd destination
|
||
|
|
|
||
|
|
let private relativeName (root: string) (path: string) =
|
||
|
|
Path.GetRelativePath(root, path).Replace(Path.DirectorySeparatorChar, '/')
|
||
|
|
|
||
|
|
let private writeEntry (writer: TarWriter) (root: string) (path: string) =
|
||
|
|
let name = relativeName root path
|
||
|
|
let attributes = File.GetAttributes path
|
||
|
|
|
||
|
|
if attributes.HasFlag FileAttributes.ReparsePoint then
|
||
|
|
let item: FileSystemInfo =
|
||
|
|
if attributes.HasFlag FileAttributes.Directory then
|
||
|
|
DirectoryInfo path
|
||
|
|
else
|
||
|
|
FileInfo path
|
||
|
|
|
||
|
|
require (not <| isNull item.LinkTarget) "invalid symbolic link"
|
||
|
|
require (not <| Path.IsPathFullyQualified item.LinkTarget) "archive link is absolute"
|
||
|
|
let entry = PaxTarEntry(TarEntryType.SymbolicLink, name)
|
||
|
|
entry.LinkName <- item.LinkTarget
|
||
|
|
entry.Mode <- File.GetUnixFileMode path
|
||
|
|
entry.ModificationTime <- DateTimeOffset.UnixEpoch
|
||
|
|
writer.WriteEntry entry
|
||
|
|
elif attributes.HasFlag FileAttributes.Directory then
|
||
|
|
let entry = PaxTarEntry(TarEntryType.Directory, name)
|
||
|
|
entry.Mode <- File.GetUnixFileMode path
|
||
|
|
entry.ModificationTime <- DateTimeOffset.UnixEpoch
|
||
|
|
writer.WriteEntry entry
|
||
|
|
else
|
||
|
|
let entry = PaxTarEntry(TarEntryType.RegularFile, name)
|
||
|
|
entry.Mode <- File.GetUnixFileMode path
|
||
|
|
entry.ModificationTime <- DateTimeOffset.UnixEpoch
|
||
|
|
entry.DataStream <- File.OpenRead path
|
||
|
|
writer.WriteEntry entry
|
||
|
|
entry.DataStream.Dispose()
|
||
|
|
|
||
|
|
let createZstd (root: string) (paths: string seq) (destination: string) =
|
||
|
|
use algorithm = SHA256.Create()
|
||
|
|
use output = File.Create destination
|
||
|
|
use hashing = new CryptoStream(output, algorithm, CryptoStreamMode.Write, true)
|
||
|
|
use zstd = new CompressionStream(hashing, 1, 131072, true)
|
||
|
|
zstd.SetParameter(ZSTD_cParameter.ZSTD_c_nbWorkers, 2)
|
||
|
|
use writer = new TarWriter(zstd, TarEntryFormat.Pax, leaveOpen = false)
|
||
|
|
|
||
|
|
paths
|
||
|
|
|> Seq.collect (fun path -> tree (Path.Combine(root, path)))
|
||
|
|
|> Seq.distinct
|
||
|
|
|> Seq.sortBy (relativeName root)
|
||
|
|
|> Seq.iter (writeEntry writer root)
|
||
|
|
|
||
|
|
writer.Dispose()
|
||
|
|
zstd.Dispose()
|
||
|
|
hashing.FlushFinalBlock()
|
||
|
|
Convert.ToHexString(algorithm.Hash).ToLowerInvariant()
|
||
|
|
|
||
|
|
let validateCertificate
|
||
|
|
(root: X509Certificate2)
|
||
|
|
(certificate: X509Certificate)
|
||
|
|
(providedChain: X509Chain)
|
||
|
|
(errors: SslPolicyErrors)
|
||
|
|
=
|
||
|
|
not (isNull certificate)
|
||
|
|
&& not (isNull providedChain)
|
||
|
|
&& not (errors.HasFlag SslPolicyErrors.RemoteCertificateNameMismatch)
|
||
|
|
&& (use chain = new X509Chain()
|
||
|
|
chain.ChainPolicy.TrustMode <- X509ChainTrustMode.CustomRootTrust
|
||
|
|
chain.ChainPolicy.CustomTrustStore.Add root |> ignore
|
||
|
|
chain.ChainPolicy.RevocationMode <- X509RevocationMode.NoCheck
|
||
|
|
|
||
|
|
providedChain.ChainElements
|
||
|
|
|> Seq.iter (fun item -> chain.ChainPolicy.ExtraStore.Add item.Certificate |> ignore)
|
||
|
|
|
||
|
|
chain.Build(new X509Certificate2(certificate)))
|