unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 02:25:39 +03:00
Code Issues Projects Releases Wiki Activity

delete superfluous builtin-tests/*.u files

Browse Source
This commit is contained in:
Arya Irani 2024-04-04 01:36:54 -06:00
parent f5d187ef84
commit 4289192d36
18 changed files with 0 additions and 1918 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
unison-src/builtin-tests/array-tests.u
View File

@ -1,107 +0,0 @@
checkBytesII src larr rarr i =
l = data.ByteArray.Raw.read8 larr i
r = data.ByteArray.Raw.read8 rarr i
if l == r
then if i > 0 then checkBytesII src larr rarr (l-1) else pass src
else let
tl = Debug.evalToText l
tr = Debug.evalToText r
fail src ("`" ++ tl ++ "` is not equal to `" ++ tr ++ "`")
checkBytesMI src marr iarr i =
l = mutable.ByteArray.Raw.read8 marr i
r = data.ByteArray.Raw.read8 iarr i
if l == r
then if i > 0 then checkBytesMI src marr iarr (l-1) else pass src
else let
tl = Debug.evalToText l
tr = Debug.evalToText r
fail src ("`" ++ tl ++ "` is not equal to `" ++ tr ++ "`")
checkBytesMM src larr rarr i =
l = mutable.ByteArray.Raw.read8 larr i
r = mutable.ByteArray.Raw.read8 rarr i
if l == r
then if i > 0 then checkBytesMM src larr rarr (l-1) else pass src
else let
tl = Debug.evalToText l
tr = Debug.evalToText r
fail src ("`" ++ tl ++ "` is not equal to `" ++ tr ++ "`")
boxarrTests : '{IO,Exception,Tests} ()
boxarrTests = do
iarr = Scope.run do
marr = Scope.Raw.array 1
checkEqual "boxed array/msize" (Array.Raw.size marr) 1
Array.Raw.write marr 0 "hello"
checkEqual "boxed mut read/write" (Array.Raw.read marr 0) "hello"
freeze marr 0 1
checkEqual "boxed new/size" (Array.Raw.size iarr) 1
checkEqual "boxed imm read/write" (Array.Raw.read iarr 0) "hello"
iarr2 = Scope.run do
marr = Scope.Raw.array 1
data.Array.Raw.copyTo! marr 0 iarr 0 1
checkEqual "immuntable copyTo!" (Raw.read marr 0) "hello"
marr2 = Scope.Raw.arrayOf "goodbye" 1
mutable.Array.Raw.copyTo! marr2 0 marr 0 1
checkEqual "mutable copyTo!" (Raw.read marr 0) "hello"
freeze! marr2
checkEqual "boxed immutable copied" (Raw.read iarr2 0) "hello"
bs = Value.serialize (Value.value iarr2)
match Value.deserialize bs with
Left err -> fail "boxed serial" err
Right v -> match Value.load v with
Left missing -> fail "boxed serial" "missing deps"
Right ia -> checkEqual "boxed serial" iarr2 ia
bytearrTests : '{IO,Exception,Tests} ()
bytearrTests = do
iarr = ByteArray.Raw.new! 32 (marr -> let
checkEqual "byte new/msize" (ByteArray.Raw.size marr) 32
ByteArray.Raw.write64be marr 0 0xffffffff
ByteArray.Raw.write32be marr 8 0xffff
ByteArray.Raw.write16be marr 12 0xff
ByteArray.Raw.write8 marr 14 0xf
n64 = mutable.ByteArray.Raw.read64be marr 0
n40 = mutable.ByteArray.Raw.read40be marr 0
n32 = mutable.ByteArray.Raw.read32be marr 8
n24 = mutable.ByteArray.Raw.read24be marr 8
n16 = mutable.ByteArray.Raw.read16be marr 12
n8 = mutable.ByteArray.Raw.read8 marr 14
checkEqual "byte mut read/write 64" n64 0xffffffff
checkEqual "byte mut read/write 40" n40 0xff
checkEqual "byte mut read/write 32" n32 0xffff
checkEqual "byte mut read/write 24" n24 0xff
checkEqual "byte mut read/write 16" n16 0xff
checkEqual "byte mut read/write 8" n8 0xf)
checkEqual "byte new/size" (ByteArray.Raw.size iarr) 32
n64 = data.ByteArray.Raw.read64be iarr 0
n40 = data.ByteArray.Raw.read40be iarr 0
n32 = data.ByteArray.Raw.read32be iarr 8
n24 = data.ByteArray.Raw.read24be iarr 8
n16 = data.ByteArray.Raw.read16be iarr 12
n8 = data.ByteArray.Raw.read8 iarr 14
checkEqual "byte imm read/write 64" n64 0xffffffff
checkEqual "byte imm read/write 40" n40 0xff
checkEqual "byte imm read/write 32" n32 0xffff
checkEqual "byte imm read/write 24" n24 0xff
checkEqual "byte imm read/write 16" n16 0xff
checkEqual "byte imm read/write 8" n8 0xf
iarr2 = Scope.run do
marr = Scope.Raw.byteArray 32
data.ByteArray.Raw.copyTo! marr 0 iarr 0 32
checkBytesMI "byte immutable copyTo!" marr iarr 31
marr2 = Scope.Raw.byteArray 32
mutable.ByteArray.Raw.copyTo! marr2 0 marr 0 32
checkBytesMM "byte mutable copyTo!" marr2 marr 31
freeze! marr2
checkBytesII "byte immutable copied" iarr iarr2 31
array.tests = do
!bytearrTests
!boxarrTests

203
unison-src/builtin-tests/bytes-tests.u
View File

@ -1,203 +0,0 @@
use base.Text toUtf8
bytes.tests = do
!bytes.lit.tests
!bytes.debug.tests
!bytes.conversion.tests
!bytes.eq.tests
!bytes.ord.tests
!bytes.ops.tests
!bytes.gzip.compress.tests
!bytes.gzip.decompress.tests
!bytes.zlib.compress.tests
!bytes.zlib.decompress.tests
!bytes.toFromBases
!bytes.decodeNats
!bytes.encodeNats
bytes.lit.tests = do
check "Bytes empty literal" do
_ = 0xs
true
check "Bytes literal" do
_ = 0xs68656c6c6f
true
bytes.debug.tests = do
checkEqual "Debug.evalToText on Bytes" (Debug.evalToText 0xs68656c6c6f) "0xs68656c6c6f"
bytes.conversion.tests = do
use base Bytes.fromList Bytes.toList
checkEqual "Bytes.fromList: empty" (Bytes.fromList []) Bytes.empty
checkEqual "Bytes.fromList: non empty" (Bytes.fromList [104, 101, 108, 108, 111]) 0xs68656c6c6f
check "Bytes.fromList: invalid" do
match catch '(Bytes.fromList [104, 500]) with
Left _ -> true
Right _ -> false
checkEqual "Bytes.toList: empty" (Bytes.toList Bytes.empty) []
checkEqual "Bytes.toList: non empty" (Bytes.toList 0xs68656c6c6f) [104, 101, 108, 108, 111]
check "fromUtf8: invalid" do
match catch '(Text.fromUtf8 0xsfc80808080af) with
Left _ -> true
Right _ -> false
checkEqual "fromUtf8" (Text.fromUtf8 0xs68656c6c6f) "hello"
checkEqual "toUtf8" (Text.toUtf8 "hello") 0xs68656c6c6f
loremIpsum = """
In Unison, since definitions are identified by a content hash,
arbitrary computations can just be moved from one location to
another, with missing dependencies deployed on the fly.
The basic protocol is something like: the sender ships the bytecode
tree to the recipient, who inspects the bytecode for any hashes it's
missing. If it already has all the hashes, it can run the
computation; otherwise, it requests the ones it's missing and the
sender syncs them on the fly. They'll be cached for next time.
Of course, there's a lot of engineering that goes into making this
work nicely, but the basic idea is simple and robust.
This ability to relocate arbitrary computations subsumes the more
limited notions of code deployment, remote procedure calls, and more,
and lets us build powerful distributed computing components as
ordinary Unison libraries.
"""
checkEqual "ut8 roundTrip" (fromUtf8 (toUtf8 loremIpsum)) loremIpsum
bytes.eq.tests = do
checkEqual "Bytes equality: empty" 0xs 0xs
checkEqual "Bytes equality: non empty" 0xs0102 0xs0102
check "Bytes inequality: non empty (1)" do 0xs0102 !== 0xs010203
check "Bytes inequality: non empty (2)" do 0xs010203 !== 0xs0102
check "Bytes inequality: non empty (3)" do 0xs0102 !== 0xs0103
check "Bytes inequality: empty" do 0xs0102 !== 0xs
checkEqual "Bytes equality: composite" (Some [0xs010203, 0xs040506]) (Some [0xs010203, 0xs040506])
check "Bytes inequality: composite" do (Some [0xs010203, 0xs040506]) !== (Some [0xs010203, 0xs68656c6c6f])
bytes.ord.tests = do
checkEqual "Bytes ordering (1)" (Universal.compare 0xs01 0xs) +1
checkEqual "Bytes ordering (2)" (Universal.compare 0xs 0xs01) -1
checkEqual "Bytes ordering (3)" (Universal.compare 0xs0100 0xs01) +1
checkEqual "Bytes ordering (4)" (Universal.compare 0xs02 0xs0102) +1
checkEqual "Bytes ordering (5)" (Universal.compare 0xs0103 0xs0102) +1
checkEqual "Bytes ordering (6)" (Universal.compare 0xs010203 0xs010203) +0
bytes.ops.tests = do
checkEqual "Bytes.flatten" (Bytes.flatten 0xs68656c6c6f) 0xs68656c6c6f
checkEqual "Bytes.++" (0xs ++ 0xs0102 ++ 0xs0304 ++ 0xs) 0xs01020304
checkEqual "Bytes.take (1)" (Bytes.take 0 0xs010203) 0xs
checkEqual "Bytes.take (2)" (Bytes.take 2 0xs010203) 0xs0102
checkEqual "Bytes.take (3)" (Bytes.take 3 0xs010203) 0xs010203
checkEqual "Bytes.take (4)" (Bytes.take 100 0xs010203) 0xs010203
checkEqual "Bytes.take (5)" (Bytes.take 3 0xs) 0xs
checkEqual "Bytes.drop (1)" (Bytes.drop 0 0xs010203) 0xs010203
checkEqual "Bytes.drop (2)" (Bytes.drop 2 0xs010203) 0xs03
checkEqual "Bytes.drop (3)" (Bytes.drop 3 0xs010203) 0xs
checkEqual "Bytes.drop (4)" (Bytes.drop 100 0xs010203) 0xs
checkEqual "Bytes.drop (5)" (Bytes.drop 3 0xs) 0xs
checkEqual "Bytes.size (1)" (Bytes.size 0xs) 0
checkEqual "Bytes.size (2)" (Bytes.size 0xs010203) 3
checkEqual "Bytes.at (1)" (Bytes.at 0 0xs010203) (Some 1)
checkEqual "Bytes.at (2)" (Bytes.at 2 0xs010203) (Some 3)
checkEqual "Bytes.at (3)" (Bytes.at 1 0xs) None
checkEqual "Bytes.at (4)" (Bytes.at 5 0xs010203) None
checkEqual "Bytes.indexOf (1)" (Bytes.indexOf 0xs 0xs0102030304) (Some 0)
checkEqual "Bytes.indexOf (2)" (Bytes.indexOf 0xs03 0xs0102030304) (Some 2)
checkEqual "Bytes.indexOf (3)" (Bytes.indexOf 0xs0304 0xs0102030304) (Some 3)
checkEqual "Bytes.indexOf (3)" (Bytes.indexOf 0xs020304 0xs0102030304) None
-- Haskell and Racket produce slightly different byte output
-- for gzip compress (in the header, racket reports the OS as "unix"
-- while Haskell for some reason claims to be Acorn RISCOS),
-- so we can't compare gzip.compress to the actual byte output.
-- We'll have to settle for testing the round-trip.
bytes.gzip.compress.tests = do
checkEqual "gzip empty" (gzip.decompress (gzip.compress (toUtf8 ""))) (Right (toUtf8 ""))
checkEqual "gzip hello folks" (gzip.decompress (gzip.compress (toUtf8 "hello folks"))) (Right (toUtf8 "hello folks"))
bytes.gzip.decompress.tests = do
checkEqual "gunzip empty" (gzip.decompress 0xs1f8b080000000000001303000000000000000000) (Right (toUtf8 ""))
checkEqual "gunzip hello folks" (gzip.decompress 0xs1f8b0800000000000013cb48cdc9c95748cbcfc92e0600cd32e08a0b000000) (Right (toUtf8 "hello folks"))
bytes.zlib.compress.tests = do
checkEqual "zlib empty" (zlib.compress (toUtf8 "")) 0xs789c030000000001
checkEqual "zlib hello folks" (zlib.compress (toUtf8 "hello folks")) 0xs789ccb48cdc9c95748cbcfc92e060019b10454
bytes.zlib.decompress.tests = do
checkEqual "zlib inflate empty" (zlib.decompress 0xs789c030000000001) (Right (toUtf8 ""))
checkEqual "zlib inflate hello folks" (zlib.decompress 0xs789ccb48cdc9c95748cbcfc92e060019b10454) (Right (toUtf8 "hello folks"))
checkLeft : Text -> Either a b ->{Tests} ()
checkLeft msg a1 =
match a1 with
Left _ -> Tests.pass msg
Right _ ->
Debug.trace "value" a1
Tests.fail msg "not Left"
bytes.toFromBases = do
checkEqual "base16 empty" (Bytes.toBase16 (toUtf8 "")) 0xs
checkEqual "from base16 empty" (Bytes.fromBase16 0xs) (Right 0xs)
checkEqual "base16 hello" (Bytes.toBase16 (toUtf8 "hello")) (toUtf8 "68656c6c6f")
checkEqual "from base16 hello" (Bytes.fromBase16 (toUtf8 "68656c6c6f")) (Right (toUtf8 "hello"))
checkEqual "base32 hello" (Bytes.toBase32 (toUtf8 "hello")) (toUtf8 "NBSWY3DP")
checkEqual "from base32 hello" (Bytes.fromBase32 (toUtf8 "NBSWY3DP")) (Right (toUtf8 "hello"))
checkEqual "base64 hello" (Bytes.toBase64 (toUtf8 "hello")) (toUtf8 "aGVsbG8=")
checkEqual "from base64 hello" (Bytes.fromBase64 (toUtf8 "aGVsbG8=")) (Right (toUtf8 "hello"))
checkEqual "base64Url hello" (toBase64UrlUnpadded (toUtf8 "hello")) (toUtf8 "aGVsbG8")
checkEqual "from base64Url hello" (fromBase64UrlUnpadded (toUtf8 "aGVsbG8")) (Right (toUtf8 "hello"))
-- false ones
checkLeft "from base16 fail non-utf8" (Bytes.fromBase16 0xsaaaa)
checkLeft "from base32 fail non-utf8" (Bytes.fromBase32 0xsaaaa)
checkLeft "from base64 fail non-utf8" (Bytes.fromBase64 0xsaaaa)
checkLeft "from base64Url fail non-utf8" (fromBase64UrlUnpadded 0xsaaaa)
-- NOTE: the haskell implementation doesn't reject these invocations,
-- even though though they are invalid :(. It just returns the same
-- bytes that it received, confusingly.
-- checkLeft "from base16 fail" (Bytes.fromBase16 (toUtf8 "aaaa"))
-- checkLeft "from base64 fail" (Bytes.fromBase64 (toUtf8 "aaaa"))
-- checkLeft "from base64Url fail" (fromBase64UrlUnpadded (toUtf8 "aaaa"))
checkLeft "from base32 fail" (Bytes.fromBase32 (toUtf8 "aaaa"))
bytes.decodeNats = do
checkEqual "decodeNat16be 1" (base.Bytes.decodeNat16be 0xs0001aa) (Some (1, 0xsaa))
checkEqual "decodeNat16be 10000" (base.Bytes.decodeNat16be 0xs2710bb) (Some (10000, 0xsbb))
checkEqual "decodeNat16le 1" (base.Bytes.decodeNat16le 0xs0100cc) (Some (1, 0xscc))
checkEqual "decodeNat16le 10000" (base.Bytes.decodeNat16le 0xs1027dd) (Some (10000, 0xsdd))
checkEqual "decodeNat32be 1" (base.Bytes.decodeNat32be 0xs00000001) (Some (1, 0xs))
checkEqual "decodeNat32be 1000000000" (base.Bytes.decodeNat32be 0xs3b9aca00) (Some (1000000000, 0xs))
checkEqual "decodeNat32le 1" (base.Bytes.decodeNat32le 0xs01000000) (Some (1, 0xs))
checkEqual "decodeNat32le 1000000000" (base.Bytes.decodeNat32le 0xs00ca9a3b) (Some (1000000000, 0xs))
checkEqual "decodeNat64be 1" (base.Bytes.decodeNat64be 0xs0000000000000001) (Some (1, 0xs))
checkEqual "decodeNat64be 10000000000000000" (base.Bytes.decodeNat64be 0xs002386f26fc10000) (Some (10000000000000000, 0xs))
checkEqual "decodeNat64le 1" (base.Bytes.decodeNat64le 0xs0100000000000000) (Some (1, 0xs))
checkEqual "decodeNat64le 10000000000000000" (base.Bytes.decodeNat64le 0xs0000c16ff2862300) (Some (10000000000000000, 0xs))
bytes.encodeNats = do
checkEqual "encodeNat16be 1" (base.Bytes.encodeNat16be 1) 0xs0001
checkEqual "encodeNat16be 10000" (base.Bytes.encodeNat16be 10000) 0xs2710
checkEqual "encodeNat16le 1" (base.Bytes.encodeNat16le 1) 0xs0100
checkEqual "encodeNat16le 10000" (base.Bytes.encodeNat16le 10000) 0xs1027
checkEqual "encodeNat32be 1" (base.Bytes.encodeNat32be 1) 0xs00000001
checkEqual "encodeNat32be 1000000000" (base.Bytes.encodeNat32be 1000000000) 0xs3b9aca00
checkEqual "encodeNat32le 1" (base.Bytes.encodeNat32le 1) 0xs01000000
checkEqual "encodeNat32le 1000000000" (base.Bytes.encodeNat32le 1000000000) 0xs00ca9a3b
checkEqual "encodeNat64be 1" (base.Bytes.encodeNat64be 1) 0xs0000000000000001
checkEqual "encodeNat64be 10000000000000000" (base.Bytes.encodeNat64be 10000000000000000) 0xs002386f26fc10000
checkEqual "encodeNat64le 1" (base.Bytes.encodeNat64le 1) 0xs0100000000000000
checkEqual "encodeNat64le 10000000000000000" (base.Bytes.encodeNat64le 10000000000000000) 0xs0000c16ff2862300

31
unison-src/builtin-tests/code-lookup.u
View File

@ -1,31 +0,0 @@
codelookup.links =
[ termLink data.Map.adjust
, termLink data.Map.alter
, termLink data.Map.contains
, termLink data.Map.delete
, termLink data.Map.difference
, termLink data.List.any
, termLink data.List.apply
, termLink data.List.compare
, termLink data.List.contains
, termLink data.List.count
, termLink data.List.diagonal
, termLink data.List.distinct
, termLink data.NatSet.alter
, termLink data.NatSet.any
, termLink data.NatSet.empty
, termLink data.NatSet.filter
, termLink data.Tuple.at1
, termLink data.Tuple.at2
, termLink data.Tuple.at3
, termLink data.Tuple.bimap
, termLink data.Tuple.mapLeft
, termLink data.graph.SCC.map
]
codelookup.tests : '{Tests,IO} ()
codelookup.tests = do
foreach codelookup.links (l -> match Code.lookup l with
None -> fail "codelookup" ("missing code for: " ++ toText l)
Some _ -> pass ("codelookup " ++ toText l))

161
unison-src/builtin-tests/concurrency-tests.u
View File

@ -1,161 +0,0 @@
concurrency.tests = do
!simpleRefTest
!simpleRefTestScope
!ticketTest
!casTest
!promiseSequentialTest
!promiseConcurrentTest
!forkKillTest
!tryEvalForkTest
!tryEvalKillTest
!fullTest
simpleRefTest = do
r = IO.ref 0
Ref.write r 1
i = Ref.read r
Ref.write r 2
j = Ref.read r
Ref.write r 5
checkEqual "Ref read-write" (i, j, Ref.read r) (1, 2, 5)
simpleRefTestScope = do
Scope.run do
r = Scope.ref 0
Ref.write r 1
i = Ref.read r
Ref.write r 2
j = Ref.read r
Ref.write r 5
checkEqual "Ref read-write" (i, j, Ref.read r) (1, 2, 5)
ticketTest = do
r = IO.ref 3
t = Ref.readForCas r
v = Ticket.read t
checkEqual "Ticket contains the Ref value" v 3
casTest = do
ref = IO.ref 0
ticket = Ref.readForCas ref
v1 = Ref.cas ref ticket 5
check "CAS is successful is there were no conflicting writes" 'v1
Ref.write ref 10
v2 = Ref.cas ref ticket 15
check "CAS fails when there was an intervening write" '(not v2)
promiseSequentialTest = do
use Nat eq
use Promise read write
p = !Promise.new
v0 = Promise.tryRead p
checkEqual "Promise should be empty when created" v0 None
Promise.write_ p 0
v1 = read p
checkEqual "Promise should read a value that's been written" v1 0
Promise.write_ p 1
v2 = read p
checkEqual "Promise can only be written to once" v2 v1
v3 = Promise.tryRead p
checkEqual "Once the Promise is full, tryRead is the same as read" v3 (Some v2)
millis = 1000
sleep_ n = unsafeRun! do sleepMicroseconds n
promiseConcurrentTest = do
use Nat eq
use concurrent fork
p = !Promise.new
_ = fork do
sleep_ (200 * millis)
Promise.write p 5
v = Promise.read p
checkEqual "Reads awaits for completion of the Promise" v 5
kill_ t = unsafeRun! do concurrent.kill t
forkKillTest = do
ref = IO.ref "initial"
thread = fork do
sleep_ (400 * millis)
Ref.write ref "done"
sleep_ (200 * millis)
kill_ thread
sleep_ (300 * millis)
v = Ref.read ref
checkEqual "Thread was killed" v "initial"
tryEvalForkTest = do
ref = IO.ref "initial"
t = fork do
match catchAll do sleep_ (400 * millis) with
Left _ -> ()
Right _ -> unsafeRun! do Ref.write ref "finished"
sleep_ (500 * millis)
v = Ref.read ref
checkEqual "tryEval is a no-op on success" v "finished"
tryEvalKillTest = do
ref = IO.ref "initial"
t = fork do
match catchAll do sleep_ (400 * millis) with
Left (Failure typ msg a) -> unsafeRun! do Ref.write ref msg
Right _ -> unsafeRun! do Ref.write ref "finished"
sleep_ (200 * millis)
kill_ t
sleep_ (300 * millis)
v = Ref.read ref
checkEqual "Thread was killed, with finalisers" v "thread killed"
atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} ()
atomicUpdate ref f =
ticket = Ref.readForCas ref
value = f (Ticket.read ticket)
if Ref.cas ref ticket value then () else atomicUpdate ref f
spawnN : Nat -> '{IO} a ->{IO} [a]
spawnN n fa =
use Nat eq -
use concurrent fork
go i acc =
if eq i 0
then acc
else
value = !Promise.new
_ = fork do Promise.write value !fa
go (i - 1) (acc :+ value)
map Promise.read (go n [])
fullTest = do
use Nat * + eq -
numThreads = 100
iterations = 100
expected = numThreads * iterations
state = IO.ref 0
thread n =
if eq n 0
then ()
else
atomicUpdate state (v -> v + 1)
thread (n - 1)
ignore (spawnN numThreads '(thread iterations))
result = Ref.read state
checkEqual "The state of the counter is consistent " result expected
concurrency.interpreter.only = Tests.main do
ref = IO.ref None
t = fork do
match catchAll do sleep_ (400 * millis) with
Left (Failure f _ _) -> unsafeRun! do Ref.write ref (Some f)
_ -> ()
sleep_ (200 * millis)
kill_ t
sleep_ (300 * millis)
v = Ref.read ref
expected = Some (typeLink ThreadKilledFailure)
checkEqual "Thread killed, finalisers with typeLink" v expected

280
unison-src/builtin-tests/io-tests.u
View File

@ -1,280 +0,0 @@
io.tests = Tests.main do
!test_getFileSize
!test_getFileSize_err
!test_getFileTimestamp
!test_getFileTimestamp_err
!io.test.seek.absolute
!io.test.seek.relative
!io.test.getLine
!io.test.getsetBuffering
!io.test_getEcho
!io.test_getArgs
!io.test_getEnv
!io.test.getRandomBytes
!io.test_getSomeBytes
!io.test_getChar
!io.test_getCurrentDirectory
!io.test_createTempDirectory
!io.test_renameFile
!io.test_isFileOpen
!io.test_ready
!io.test_now
!io.test_isSeekable
!io.test_handlePosition
!io.test_renameDirectory
!io.test_setCurrentDirectory
rm_if_exists fp =
if FilePath.exists fp
then
if isDirectory fp then
removeDirectory fp
else
removeFile fp
else
()
testFile = do
fp = FilePath ((FilePath.toText !getTempDirectory) ++ "/unison-test")
rm_if_exists fp
fp
io.test_isSeekable = do
fp = !testFile
fhandle = open fp Write
checkEqual "isSeekable file" true (isSeekable fhandle)
io.test_handlePosition = do
fp = !testFile
writeFile fp "123456"
fhandle = open fp Read
checkEqual "handlePosition initial" 0 (position fhandle)
_ = getBytes fhandle 2
checkEqual "handlePosition" 2 (position fhandle)
io.test_deprecated_systemTimeMicroseconds = do
match !systemTimeMicroseconds with
micro ->
if micro Int.> +10 then
Tests.pass "!systemTimeMicroseconds"
else
Tests.fail "!systemTimeMicroseconds" "systemTime is too small"
io.test_deprecated_systemTime = do
match !systemTime with
EpochTime seconds ->
if seconds > 10 then
Tests.pass "!systemTime"
else
Tests.fail "!systemTime" "systemTime is too small"
io.test_now = do
match !now with
Instant a b ->
if a Int.> +10 then
Tests.pass "!now"
else
Tests.fail "!now" "now is too small"
io.test_createTempDirectory = do
tmp = (createTempDirectory (FilePath "prefix-"))
match tmp with
FilePath text -> if Text.contains "/prefix-" text then
if exists tmp then
removeDirectory tmp
Tests.pass "Tmp directory exists and contains prefix-"
else
Tests.fail "Tmp directory doesn't exist" text
else
Tests.fail "Tmp directory doesn't contain prefix-" text
io.test_isFileOpen = do
fp = FilePath ((FilePath.toText !getTempDirectory) ++ "/unison-test")
fhandle = open fp Write
open1 = isOpen fhandle
Handle.close fhandle
open2 = isOpen fhandle
rm_if_exists fp
checkEqual "opened handle is open" open1 true
checkEqual "closed handle is not open" open2 false
io.test_ready = do
fp = !testFile
_ = writeFile fp "What"
fhandle = open fp Read
ready1 = ready fhandle
checkEqual "handle with text ready is ready" ready1 true
join fp text =
FilePath (FilePath.toText fp ++ "/" ++ text)
io.test_renameDirectory = do
td = join !getTempDirectory "unison-dir"
rd = join !getTempDirectory "unison-dir-rename"
rm_if_exists td
rm_if_exists rd
createDirectory td
contents = "a file contents"
_ = writeFile (join td "hello") contents
renameDirectory td rd
got = (getText (open (join rd "hello") Read))
rm_if_exists td
rm_if_exists rd
checkEqual "renameFile" contents got
io.test_renameFile = do
fp = FilePath ((FilePath.toText !getTempDirectory) ++ "/unison-test")
rmp = FilePath ((FilePath.toText !getTempDirectory) ++ "/unison-test-renamed")
rm_if_exists fp
rm_if_exists rmp
contents = "a file contents"
_ = writeFile fp contents
renameFile fp rmp
got = (getText (open rmp Read))
rm_if_exists fp
rm_if_exists rmp
checkEqual "renameFile" contents got
writeFile fp txt =
fh = open fp Write
putText fh txt
close fh
test_getFileSize = do
fp = !testFile
_ = writeFile fp "What"
fs = (FilePath.getSize fp)
checkEqual "Get file size should work" fs 4
removeFile fp
test_getFileSize_err = do
expectError' "File size of missing file" ["does not exist", "cannot get size"] '(FilePath.getSize !testFile)
test_getFileTimestamp = do
time = secondsSinceEpoch !now
fp = !testFile
_ = writeFile fp "What"
ts = match FilePath.getTimestamp fp with Instant i _ -> i
after = secondsSinceEpoch !now
use Int - +
-- allow slip of up to a second
if ts < (time - +1) then
Tests.fail "File timestamp is too early" ((Int.toText ts) ++ " vs " ++ (Int.toText after))
else if ts > (after + +1) then
Tests.fail "File timestamp is too late" ((Int.toText ts) ++ " vs " ++ (Int.toText after))
else
Tests.pass "File timestamp is reasonable"
test_getFileTimestamp_err = do
expectError' "File timestamp of missing file" ["does not exist", "error getting"] '(FilePath.getTimestamp !testFile)
io.test_setCurrentDirectory = do
prev = !getCurrentDirectory
setCurrentDirectory (FilePath "/")
new = !getCurrentDirectory
setCurrentDirectory prev
match new with
FilePath text -> checkEqual "Current directory set & get" "/" text
io.test_getCurrentDirectory = do
match !getCurrentDirectory with
FilePath text -> if Text.startsWith "/" text then
Tests.pass "Current directory starts with /"
else
Tests.fail "Current directory doesn't start with /" text
seekFile = do
fp = !testFile
_ = writeFile fp "0123456789"
open fp Read
io.test.seek.absolute = do
h = !seekFile
seek h AbsoluteSeek +4
seek h AbsoluteSeek +2
got = getText h
checkEqual "AbsoluteSeek" got "23456789"
io.test.seek.relative = do
h = !seekFile
seek h AbsoluteSeek +2
seek h RelativeSeek +2
got = getText h
checkEqual "RelativeSeek" got "456789"
seek h RelativeSeek -2
got2 = getText h
checkEqual "RelativeSeek" got2 "89"
io.test.seek.fromEnd = do
h = !seekFile
seek h SeekFromEnd -6
seek h SeekFromEnd -4
got = getText h
checkEqual "SeekFromEnd" got "6789"
io.test.getLine = do
fp = !testFile
_ = writeFile fp "one\ntwo\nthree"
h = open fp Read
one = Handle.getLine h
two = Handle.getLine h
three = Handle.getLine h
checkEqual "getLine 1" one "one"
checkEqual "getLine 2" two "two"
checkEqual "getLine 3" three "three"
io.test.getsetBuffering = do
prev = getBuffering stdOut
setBuffering stdOut BlockBuffering
bf = getBuffering stdOut
setBuffering stdOut LineBuffering
b2 = getBuffering stdOut
setBuffering stdOut NoBuffering
b3 = getBuffering stdOut
setBuffering stdOut prev
checkEqual "Block" bf BlockBuffering
checkEqual "Line" b2 LineBuffering
checkEqual "No" b3 NoBuffering
is_a_tty = do
exitCode = call "test" ["-t", "0"]
exitCode == 0
io.test_getEcho = do
if is_a_tty () then
prev = getEcho stdIn
setEcho stdIn false
checkEqual "echo turned off" (getEcho stdIn) false
setEcho stdIn true
checkEqual "echo turned back on" (getEcho stdIn) true
setEcho stdIn prev
else
()
io.test_getArgs = do
checkEqual "cli args" !getArgs []
io.test_getEnv = do
checkEqual "HOME env variable" (startsWith "/" (getEnv "HOME")) true
io.test.getRandomBytes = do
bs = IO.randomBytes 10
checkEqual "get 10 random bytes" 10 (base.Bytes.size bs)
io.test_getChar = do
fp = !testFile
_ = writeFile fp "oón"
h = open fp Read
checkEqual "get char" (getChar h) ?o
checkEqual "get a complicated char" (getChar h) ?ó
io.test_getSomeBytes = do
fp = !testFile
_ = writeFile fp "one\ntwo\nthree"
h = open fp Read
one = getSomeBytes h 3
checkEqual "get some bytes" one (toUtf8 "one")

58
unison-src/builtin-tests/link-tests.u
View File

@ -1,58 +0,0 @@
linkstuff.termlinks =
[ termLink data.Map.adjust
, termLink data.Map.alter
, termLink data.Map.contains
, termLink data.Map.delete
, termLink data.Map.difference
, termLink data.List.any
, termLink data.List.apply
, termLink data.List.compare
, termLink data.List.contains
, termLink data.List.count
, termLink data.List.diagonal
, termLink data.List.distinct
, termLink data.NatSet.alter
, termLink data.NatSet.any
, termLink data.NatSet.empty
, termLink data.NatSet.filter
, termLink data.Tuple.at1
, termLink data.Tuple.at2
, termLink data.Tuple.at3
, termLink data.Tuple.bimap
, termLink data.Tuple.mapLeft
, termLink data.graph.SCC.map
]
linkstuff.typelinks =
[ typeLink data.Map
, typeLink Nat
, typeLink Char
, typeLink data.List
, typeLink data.NatSet
, typeLink data.Tuple
]
linkstuff.tmlpairs =
flatMap (l -> map (r -> (l,r)) termlinks) termlinks
linkstuff.tylpairs =
flatMap (l -> map (r -> (l,r)) typelinks) typelinks
linkstuff.tests : '{Tests,IO} ()
linkstuff.tests = do
use Universal gteq
if all (cases (l,r) -> (l === r) || (l !== r)) tmlpairs
then pass "term link equality"
else fail "term link equality" ""
if all (cases (l,r) -> (l === r) || (l !== r)) tylpairs
then pass "type link equality"
else fail "type link equality" ""
if all (cases (l,r) -> gteq l r || gteq r l) tmlpairs
then pass "term link comparison"
else fail "term link comparison" ""
if all (cases (l,r) -> gteq l r || gteq r l) tylpairs
then pass "type link comparison"
else fail "type link comparison" ""

143
unison-src/builtin-tests/list-tests.u
View File

@ -1,143 +0,0 @@
list.tests = do
!list.lit.tests
!list.eq.tests
!list.ord.tests
!list.ops.tests
!list.matching.tests
list.lit.tests = do
check "List empty literal" do
_ = []
true
check "List literal" do
_ = [1, 2, 3]
true
list.eq.tests = do
checkEqual "List equality: empty" [] []
checkEqual "List equality: non empty" [1, 2] [1, 2]
check "List inequality: non empty (1)" do [1, 2] !== [1, 2, 3]
check "List inequality: non empty (2)" do [1, 2, 3] !== [1, 2]
check "List inequality: non empty (3)" do [1, 2] !== [1, 3]
check "List inequality: empty" do [1, 2] !== []
checkEqual "List equality: composite" (Some [Some 1, Some 2]) (Some [Some 1, Some 2])
check "List inequality: composite" do (Some [Some 1, Some 2]) !== (Some [Some 1, Some 3])
list.ord.tests = do
checkEqual "List ordering (1)" (Universal.compare [1] []) +1
checkEqual "List ordering (2)" (Universal.compare [] [1]) -1
checkEqual "List ordering (3)" (Universal.compare [1, 0] [1]) +1
checkEqual "List ordering (4)" (Universal.compare [2] [1, 2]) +1
checkEqual "List ordering (5)" (Universal.compare [1, 3] [1, 2]) +1
checkEqual "List.ordering (6)" (Universal.compare [1, 2, 3] [1, 2, 3]) +0
list.ops.tests = do
checkEqual "List.cons" (1 +: (2 +: (3 +: []))) [1, 2, 3]
checkEqual "List.snoc" ([] :+ 1 :+ 2 :+ 3) [1, 2, 3]
checkEqual "List.++" ([] ++ [1, 2] ++ [3, 4] ++ []) [1, 2, 3, 4]
checkEqual "List.take (1)" (List.take 0 [1,2,3]) []
checkEqual "List.take (2)" (List.take 2 [1,2,3]) [1,2]
checkEqual "List.take (3)" (List.take 3 [1,2,3]) [1,2,3]
checkEqual "List.take (4)" (List.take 100 [1,2,3]) [1,2,3]
checkEqual "List.take (5)" (List.take 3 []) []
checkEqual "List.drop (1)" (List.drop 0 [1,2,3]) [1,2,3]
checkEqual "List.drop (2)" (List.drop 2 [1,2,3]) [3]
checkEqual "List.drop (3)" (List.drop 3 [1,2,3]) []
checkEqual "List.drop (4)" (List.drop 100 [1,2,3]) []
checkEqual "List.drop (5)" (List.drop 3 []) []
checkEqual "List.size (1)" (List.size []) 0
checkEqual "List.size (2)" (List.size [1,2,3]) 3
checkEqual "List.at (1)" (List.at 0 [1,2,3]) (Some 1)
checkEqual "List.at (2)" (List.at 2 [1,2,3]) (Some 3)
checkEqual "List.at (3)" (List.at 1 []) None
checkEqual "List.at (4)" (List.at 5 [1,2,3]) None
list.matching.tests = do
use Optional Some None
lenLit = cases
[] -> 0
[_] -> 1
[_, _] -> 2
[_, _, _] -> 3
_ -> bug "no"
checkEqual "length matching: literal (1)" (lenLit []) 0
checkEqual "length matching: literal (2)" (lenLit [5]) 1
checkEqual "length matching: literal (3)" (lenLit [5, 6]) 2
checkEqual "length matching: literal (4)" (lenLit [5, 6, 7]) 3
lenCons = cases
[] -> 0
_ +: (_ +: t) -> 2 + lenCons t
_ +: t -> 1 + lenCons t
checkEqual "length: cons matching" (lenCons [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15]) 15
lenSnoc = cases
[] -> 0
t :+ _ -> 1 + lenSnoc t
checkEqual "length: snoc matching" (lenSnoc [1, 2, 3, 4, 5, 6, 7, 8]) 8
lenConcat1 = cases
[] -> 0
[_] ++ tail -> 1 + lenConcat1 tail
checkEqual "length: ++ prefix matching" (lenConcat1 [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11]) 11
lenConcat2 = cases
[] -> 0
prefix ++ [_] -> 1 + lenConcat2 prefix
checkEqual "length: ++ suffix matching" (lenConcat2 [1, 2, 3, 4, 5]) 5
head = cases
h +: _ -> Some h
_ -> None
checkEqual "cons matching: empty" (head []) None
checkEqual "cons matching: non empty" (head [1, 2, 3]) (Some 1)
firstTwo = cases
x +: (y +: _) -> Some (x, y)
_ -> None
checkEqual "two cons matching (1)" (firstTwo []) None
checkEqual "two cons matching (2)" (firstTwo [1]) None
checkEqual "two cons matching (3)" (firstTwo [1, 2, 3]) (Some (1, 2))
lastTwo = cases
_ :+ x :+ y -> Some (x, y)
_ -> None
checkEqual "two snoc matching (1)" (lastTwo []) None
checkEqual "two snoc matching (2)" (lastTwo [1]) None
checkEqual "two snoc matching (3)" (lastTwo [1, 2, 3]) (Some (2, 3))
middle = cases
[_] ++ m ++ [_] -> Some m
_ -> None
checkEqual "middle matching (1)" (middle []) None
checkEqual "middle matching (2)" (middle [1, 2]) (Some [])
checkEqual "middle matching (3)" (middle [1, 2, 3, 4, 5, 6]) (Some [2, 3, 4, 5])
middleNel = cases
[_] ++ (h +: t) ++ [_] -> Some (h, t)
_ -> None
checkEqual "middle matching with non-empty list (1)" (middleNel []) None
checkEqual "middle matching with non-empty list (2)" (middleNel [1, 2]) None
checkEqual "middle matching with non-empty list (3)" (middleNel [1, 2, 3, 4, 5, 6]) (Some (2, [3, 4, 5]))
splitAtFour : [a] -> ([a], [a])
splitAtFour l = match l with
[a] ++ x@(b +: (c +: y@([] :+ d))) ++ tail -> ([a, b, c, d], tail)
_ -> (l, [])
checkEqual "Complex matching" (splitAtFour [1, 2, 3, 4, 5, 6, 7]) ([1, 2, 3, 4], [5, 6, 7])

69
unison-src/builtin-tests/math-tests.u
View File

@ -1,69 +0,0 @@
closeEnough a1 a2 =
(Float.abs (a1 - a2)) < 0.00001
Tests.checkCloseEnough : Text -> Float -> Float ->{Tests} ()
Tests.checkCloseEnough msg a1 a2 =
if closeEnough a1 a2 then
Tests.pass msg
else
Tests.fail msg "not close enough"
math.tests = do
checkCloseEnough "sin 0" (sin 0.0) 0.0
checkCloseEnough "sin pi/2" (sin (pi / 2.0)) 1.0
checkCloseEnough "cos 0" (cos 0.0) 1.0
checkCloseEnough "cos pi" (cos pi) -1.0
checkCloseEnough "cosh pi" (cosh pi) 11.591953275521519
checkCloseEnough "sinh pi/2" (sinh (pi / 2.0)) 2.3012989023072947
checkCloseEnough "addf" (1.2 + 3.4) 4.6
checkCloseEnough "asin 1.0" (asin 1.0) 1.5707963267948966
checkCloseEnough "asinh 1.0" (asinh 1.0) 0.881373587019543
checkCloseEnough "atan 1.0" (atan 1.0) 0.7853981633974483
checkCloseEnough "atan2 1.0 2.0" (atan2 1.0 2.0) 0.46364760900080615
checkCloseEnough "atanh 0.5" (atanh 0.5) 0.5493061443340549
checkCloseEnough "tan 0.5" (tan 0.5) 0.5463024898437905
checkCloseEnough "tanh 0.5" (tanh 0.5) 0.46211715726000974
checkCloseEnough "ceiling 0.1" (ceiling 0.1) 1.0
checkCloseEnough "ceiling 0.9" (ceiling 0.9) 1.0
checkCloseEnough "floor 0.9" (floor 0.9) 0.0
checkCloseEnough "floor 1.9" (floor 1.9) 1.0
checkCloseEnough "rndf" (round 1.9) 2.0
checkCloseEnough "divf" (1.2 / 3.4) 0.35294117647058826
checkEqual "maxf" (Float.max 1.2 1.23) 1.23
checkEqual "minf" (Float.min 1.2 1.23) 1.2
checkCloseEnough "mulf" (1.1 Float.* 2.2) 2.42
checkEqual "muli" (+4 Int.* +2) +8
checkEqual "powi" (Int.pow +2 3) +8
checkEqual "pown" (Nat.pow 2 3) 8
checkCloseEnough "powf" (Float.pow 2.0 3.0) 8.0
checkEqual "ntof" (Nat.toFloat 23) 23.0
checkEqual "negi" (Int.negate +23) -23
checkEqual "divi" (10 / 4) 2
checkEqual "eqlf" (1.1 == 1.1) true
checkEqual "eqlf" (1.1 == 1.2) false
checkEqual "leqi" (-1 <= +1) true
checkEqual "leqn" (1 <= 2) true
checkEqual "subi" (+4 - +3) +1
checkEqual "signum" (signum -2) -1
checkEqual "signum" (signum +2) +1
checkEqual "signum" (signum +0) +0
checkCloseEnough "logf" (Float.log 10.0) 2.302585092994046
checkCloseEnough "logb" (Float.logBase 2.0 256.0) 8.0
checkEqual "decn" (Nat.decrement 10) 9
checkEqual "deci" (Int.decrement +10) +9
checkEqual "inci" (Int.increment +10) +11
checkEqual "incn" (Nat.increment 10) 11
checkCloseEnough "expf" (Float.exp 2.0) 7.3890560989306
checkEqual "TZRO +0" (Int.trailingZeros +0) 64
checkEqual "TZRO +1" (Int.trailingZeros +1) 0
checkEqual "TZRO +16777216" (Int.trailingZeros +16777216) 24
checkEqual "TZRO 2^59" (Int.trailingZeros (Int.pow +2 59)) 59
checkEqual "POPC +16777215" (Int.popCount +16777215) 24
checkEqual "POPC +5" (Int.popCount +5) 2
checkEqual "POPC -5" (Int.popCount -5) 63
checkEqual "POPC -1" (Int.popCount -1) 64
checkEqual "POPC -1234567891" (Int.popCount -1234567891) 52
checkEqual "POPC -1111111111" (Int.popCount -1111111111) 50

60
unison-src/builtin-tests/sandbox-tests.u
View File

@ -1,60 +0,0 @@
sandbox.check ok name a k =
match Value.validateSandboxed ok (value a) with
Left _ -> Tests.fail name "unknown dependencies"
Right [] -> k true
Right _ -> k false
sandbox.checkSafe name a =
sandbox.check [] name a cases
true -> Tests.pass (name ++ " safe")
false -> Tests.fail name "unexpectedly unsafe"
sandbox.checkUnsafe name a =
sandbox.check [] name a cases
true -> Tests.fail name "unexpectedly safe"
false -> Tests.pass (name ++ " unsafe")
sandbox.checkAllowed name ok a =
sandbox.check ok name a cases
true -> Tests.pass (name ++ " allowed")
false -> Tests.fail name "unexpected disallowed"
sandbox.directory =
"unison-src/transcripts-using-base/serialized-cases/"
sandbox.file = FilePath (directory ++ "case-04.v4.ser")
sandbox.open1 = do
_ = FilePath.open (FilePath "hello")
()
sandbox.open2 = do
!open1
serial.checkLoaded : '{IO, Tests, Exception} ()
serial.checkLoaded = do
input = FilePath.readFile sandbox.file
match fromBase32 input with
Left msg -> raiseFailure msg input
Right bs ->
(deps, v) = loadValueBytes bs
_ = cache_ deps
match Value.load v with
Left l -> raiseFailure "value missing deps" l
Right (f, _) -> checkUnsafe "loaded" f
sandbox.tests = do
checkSafe "5" 5
checkSafe "5.0" 5.0
checkSafe "\"\"" ""
checkSafe "0xs1337" 0xs1337
checkSafe "List.map" List.map
checkUnsafe "FilePath.open" FilePath.open
checkUnsafe "sandbox.open1" sandbox.open1
checkUnsafe "sandbox.open2" sandbox.open2
checkUnsafe "Code.cache_" Code.cache_
checkAllowed "FilePath.open" [termLink FilePath.open.impl] FilePath.open
checkAllowed "Code.cache_" [termLink Code.cache_] Code.cache_
!checkLoaded

139
unison-src/builtin-tests/serial-tests.u
View File

@ -1,139 +0,0 @@
serial.directory =
FilePath "unison-src/transcripts-using-base/serialized-cases/"
(<+>) : FilePath -> FilePath -> FilePath
(<+>) = cases (FilePath l), (FilePath r) -> FilePath (l ++ r)
serial.availableCases : '{IO,Exception} [Text]
serial.availableCases _ =
use List map
p = cases (FilePath nm) -> contains ".ser" nm
slice = cases (FilePath nm) ->
Text.take (Text.size nm - 7) nm
-- caseNums = ["00", "01", "02", "03"]
caseNums = ["00", "02", "04"]
files = map (n -> FilePath ("case-" ++ n ++ ".v4.ser")) caseNums
map slice (filter p files)
serial.gen : Nat -> Nat -> (Nat, Nat)
serial.gen seed k =
c = 1
a = 22695477
m = shiftLeft 1 32
s = mod (a * seed + c) m
mask = shiftLeft 1 (Nat.min 14 k)
(mod (shiftRight s 15) mask, s)
serial.shuffle : Nat -> [a] -> [a]
serial.shuffle =
pick acc seed = cases
l | List.size l <= 1 -> acc ++ l
| otherwise -> match gen seed (size l) with
(k, seed) -> match (take k l, drop k l) with
(pre, x +: post) -> pick (acc :+ x) seed (pre ++ post)
(pre, []) -> pick acc seed pre
pick []
serial.checkCodeRoundtrip : Code ->{Exception,Tests,IO} Boolean
serial.checkCodeRoundtrip code0 =
match Code.deserialize (Code.serialize code0) with
Left err -> raiseFailure ("could not roundrip code: " ++ err) code0
Right code1 -> code0 === code1
serial.loadValueBytes :
base.Bytes ->{Exception,IO} ([(Link.Term, Code)], reflection.Value)
serial.loadValueBytes bs = match Value.deserialize bs with
Left err ->
raiseFailure ("could not deserialize value: " ++ err) bs
Right sv ->
if Value.serialize sv === bs then ()
else raiseFailure "reserialized bytes did not match" bs
match Value.load sv with
Left l -> raiseFailure "could not load value" ()
Right v -> v
serial.readFile : FilePath -> base.Bytes
serial.readFile fp =
h = FilePath.open fp Read
read acc =
if isEOF h
then
close h
acc
else read (acc ++ getBytes h 1024)
read 0xs
checkCached name = cases
[] -> pass (name ++ " code cached")
(ln, co0) +: rest -> match Code.lookup ln with
None -> fail name "code cache missing"
Some co1
| co0 === co1 -> checkCached name rest
| otherwise -> fail name "code cache mismatch"
serial.loadSelfContained : Text -> FilePath ->{IO, Tests, Exception} a
serial.loadSelfContained name path =
input = readFile path
match fromBase32 input with
Left msg -> raiseFailure msg input
Right bs ->
(deps, v) = loadValueBytes bs
if List.all (checkCodeRoundtrip << at2) deps
then pass (name ++ " code roundtrip")
else fail name "code roundtrip"
if Value.serialize (Value.value (deps, v)) === bs
then pass (name ++ " value roundtrip")
else fail name "value roundtrip"
match validateLinks deps with
Left [] -> fail name "validateLinks: empty Left"
Left _ -> fail name "validateLinks: couldn't rehash"
Right [] -> pass (name ++ " links validated")
Right _ -> fail name "failed link validation"
match cache_ deps with
[] -> ()
miss -> raiseFailure "code missing deps" miss
checkCached name deps
match Value.load v with
Left l -> raiseFailure "value missing deps" l
Right x -> x
serial.runTestCase : Text ->{Tests,IO} ()
serial.runTestCase name =
sfile = directory <+> FilePath (name ++ ".v4.ser")
ofile = directory <+> FilePath (name ++ ".out")
hfile = directory <+> FilePath (name ++ ".v4.hash")
handle
p@(f, i) = loadSelfContained name sfile
o = fromUtf8 (readFile ofile)
h = readFile hfile
if toBase32 (crypto.hash Sha3_512 p) === h
then pass (name ++ " hash matches")
else fail name "hash mismatch"
if f i === o
then pass (name ++ "value matches")
else fail name "output mismatch"
with cases
{ x } -> x
{ raise f -> _ } -> exception ("test failure: " ++ name) f
serial.tests : '{Tests,IO} ()
serial.tests = do
handle
l = !availableCases
m = shiftLeft 1 32
seed = mod (toRepresentation !systemTimeMicroseconds) m
cs = shuffle seed l
List.map runTestCase cs
with cases
{x} -> ()
{raise f -> k} -> exception "failed to load test cases" f

51
unison-src/builtin-tests/tcp-tests.u
View File

@ -1,51 +0,0 @@
shouldFail fn =
result = catchAll fn
isLeft result
tcp.tests = do
-- TODO: Enable this once scheme output correctly escapes \r
-- check "connects to example.com" tcp.example.com
check "rejects invalid port" do shouldFail do Socket.client (HostName "example.com") (Port "what")
check "no send after close" do shouldFail do
socket = Socket.client (HostName "example.com") (Port "80")
Socket.close socket
Socket.send socket (toUtf8 "GET /index.html HTTP/1.0\r\n\r\n")
check "no send on listener" do shouldFail do
match Socket.server None (Port "0") with
BoundServerSocket socket -> Socket.send socket (toUtf8 "what")
!testServerAndClient
tcp.example.com = do
socket = Socket.client (HostName "example.com") (Port "80")
Socket.send socket (toUtf8 "GET /index.html HTTP/1.0\r\nHost: example.com\r\n\r\n")
response = Socket.receive socket
Socket.close socket
contains "HTTP/1.0 200 OK" (base.Text.fromUtf8 response)
testServerAndClient = do
setup = catchAll do
socket = Socket.listen (server None (Port "0"))
port = match socket with ListeningServerSocket sock -> Socket.port sock
(socket, port)
match setup with
Left exn ->
Tests.fail "Unable to bind and listen on a socket" (Debug.evalToText exn)
Right (socket, port) ->
serve = do
sock = Socket.accept socket
data = Socket.receive sock
Socket.send sock (toUtf8 "from server")
base.Text.fromUtf8 data
serveResult = !Promise.new
_ = fork do Promise.write serveResult (catchAll serve)
data = catchAll do
clientSocket = Socket.client (HostName "localhost") (Port (Nat.toText port))
Socket.send clientSocket (toUtf8 "from client")
base.Text.fromUtf8 (Socket.receive clientSocket)
checkEqual "Server received data" (Promise.read serveResult) (Right "from client")
checkEqual "Client received data" data (Right "from server")

58
unison-src/builtin-tests/testlib.u
View File

@ -1,58 +0,0 @@
unique ability Tests where
pass : Text -> ()
fail : Text -> Text -> ()
exception : Text -> Failure -> ()
Tests.check : Text -> '{g, Exception} Boolean ->{g, Tests} ()
Tests.check msg b =
match catch b with
Left e -> exception msg e
Right true -> pass msg
Right false -> fail msg ""
Tests.checkEqual : Text -> a -> a ->{Tests} ()
Tests.checkEqual msg a1 a2 =
match catch '(a1 === a2) with
Left e -> exception msg e
Right true -> pass msg
Right false ->
fail msg (Debug.evalToText a1 ++ " is not equal to: " ++ Debug.evalToText a2)
Tests.main : '{IO,Exception,Tests} () -> '{IO,Exception} ()
Tests.main suite = do
if Tests.run suite then ()
else bug "test suite failed"
Tests.run : '{IO,Exception,Tests} () ->{IO,Exception} Boolean
Tests.run suite =
use Nat +
h passed failed = cases
{ _ } -> (passed, failed)
{ pass msg -> k } ->
printLine (" ✅ " ++ msg)
handle !k with h (passed + 1) failed
{ fail msg reason -> k } ->
printLine (" 🆘 " ++ msg ++ " " ++ reason)
handle !k with h passed (failed + 1)
{ exception msg failure@(Failure _ cause payload) -> k} ->
printLine (" 💥 " ++ msg ++ " " ++ cause)
handle !k with h passed (failed + 1)
printLine ""
printLine "*** Test suite ***"
printLine ""
(passed, failed) = handle !suite with h 0 0
printLine ""
printLine ""
printLine "Summary of results:"
printLine ""
if failed == 0 then
printLine (" ✅✅✅ " ++ Nat.toText passed ++ " PASSED")
else
printLine (" 🆘🆘🆘 " ++ Nat.toText failed ++ " FAILED, "
++ Nat.toText passed ++ " passed")
failed == 0

5
unison-src/builtin-tests/tests-interpreter-only.u
View File

@ -1,5 +0,0 @@
tests.interpreter.only : '{IO,Exception} ()
tests.interpreter.only = Tests.main do
!text.interpreter.only
!concurrency.interpreter.only
!io.test.seek.fromEnd

5
unison-src/builtin-tests/tests-jit-only.u
View File

@ -1,5 +0,0 @@
tests.jit.only : '{IO,Exception} ()
tests.jit.only = Tests.main do
check "example jit-only test" do true
!tls.cert.codec
!tls.private.codec

67
unison-src/builtin-tests/tests.u
View File

@ -1,67 +0,0 @@
tests : '{IO,Exception} ()
tests = Tests.main do
!math.tests
!io.tests
!tls.tests
!crypto.hash.tests
!murmur.hash.tests
!hmac.tests
!concurrency.tests
!tcp.tests
!serial.tests
-- TODO add test assert on message and value for both bug and todo
check "bug is caught" do isLeft (catchAll do bug ())
!list.tests
!text.tests
!bytes.tests
!array.tests
!codelookup.tests
!sandbox.tests
!linkstuff.tests
murmur.hash.tests = do
targets =
[ 3616548711131950114
, 1208954131003843843
, 664611890102475300
, 6714987116946118165
, 16299576272983505103
, 4073299915095202490
, 12366602710912766676
, 7206684309820213116
, 18221756083322989289
, 15843896009975349171
]
process i t =
name = "murmurHash " ++ toText i
checkEqual name (murmurHash i) t
List.foreach_ (uncurry process) <| List.zip (List.range 0 10) targets
crypto.hash.tests = do
hash alg = hashBytes alg (toUtf8 "")
tag name = name ++ " hashBytes"
[
("Md5", Md5, 0xsd41d8cd98f00b204e9800998ecf8427e),
("Sha1", Sha1, 0xsda39a3ee5e6b4b0d3255bfef95601890afd80709),
("Sha2_256", Sha2_256, 0xse3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855),
("Sha2_512", Sha2_512, 0xscf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e),
("Sha3_256", Sha3_256, 0xsa7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a),
("Sha3_512", Sha3_512, 0xsa69f73cca23a9ac5c8b567dc185a756e97c982164fe25859e0d1dcc1475c80a615b2123af1f5f94c11e3e9402c3ac558f500199d95b6d3e301758586281dcd26),
("Blake2s_256", Blake2s_256, 0xs69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9),
("Blake2b_256", Blake2b_256, 0xs0e5751c026e543b2e8ab2eb06099daa1d1e5df47778f7787faab45cdf12fe3a8),
("Blake2b_512", Blake2b_512, 0xs786a02f742015903c6c6fd852552d272912f4740e15847618a86e217f71f5419d25e1031afee585313896444934eb04b903a685b1448b755d56f701afe9be2ce)
] |> List.foreach_ cases (name, alg, res) -> checkEqual (tag name) (hash alg) res
hmac.tests = do
hmac alg = hmacBytes alg (toUtf8 "key") (toUtf8 "")
tag name = name ++ " hmacBytes"
[
("Sha1", Sha1, 0xsf42bb0eeb018ebbd4597ae7213711ec60760843f),
("Sha2_256", Sha2_256, 0xs5d5d139563c95b5967b9bd9a8c9b233a9dedb45072794cd232dc1b74832607d0),
("Sha2_512", Sha2_512, 0xs84fa5aa0279bbc473267d05a53ea03310a987cecc4c1535ff29b6d76b8f1444a728df3aadb89d4a9a6709e1998f373566e8f824a8ca93b1821f0b69bc2a2f65e),
("Sha3_256", Sha3_256, 0xs74f3c030ecc36a1835d04a333ebb7fce2688c0c78fb0bcf9592213331c884c75),
("Sha3_512", Sha3_512, 0xs7539119b6367aa902bdc6f558d20c906d6acbd4aba3fd344eb08b0200144a1fa453ff6e7919962358be53f6db2a320d1852c52a3dea3e907070775f7a91f1282),
("Blake2s_256", Blake2s_256, 0xs67148074efc0f6741b474ef81c4d98d266e880d372fe723d2569b1d414d234be),
("Blake2b_256", Blake2b_256, 0xs4224e1297e51239a642e21f756bde2785716f872298178180d7f3d1d36a5e4e4),
("Blake2b_512", Blake2b_512, 0xs019fe04bf010b8d72772e6b46897ecf74b4878c394ff2c4d5cfa0b7cc9bbefcb28c36de23cef03089db9c3d900468c89804f135e9fdef7ec9b3c7abe50ed33d3)
] |> List.foreach_ cases (name, alg, res) -> checkEqual (tag name) (hmac alg) res

246
unison-src/builtin-tests/text-tests.u
View File

@ -1,246 +0,0 @@
text.tests = do
!text.lit.tests
!text.eq.tests
!text.ord.tests
!text.ops.tests
!text.conversion.tests
!text.debug.tests
!text.matching.tests
!char.class.tests
text.interpreter.only = do
!text.term.tests
text.lit.tests = do
check "Text empty literal" do
_ = ""
true
check "Text literal" do
_ = "foo"
true
text.eq.tests = do
check "Text equality: empty" do "" Text.== ""
check "Text equality: non empty" do "foo" Text.== "foo"
check "Text inequality: empty (1)" do not ("foo" Text.== "")
check "Text inequality: empty (2)" do not ("" Text.== "foo")
check "Text inequality: non empty" do not ("foo" Text.== "bar")
checkEqual "Universal equality with Text: empty" "" ""
checkEqual "Universal equality with Text: non empty" "foo" "foo"
check "Universal inequality with Text: empty (1)" do "foo" !== ""
check "Universal inequality with Text: empty (2)" do "" !== "foo"
check "Universal inequality with Text: non empty" do "foo" !== "bar"
checkEqual "Universal equality with Text: composite" (Some ["foo", "bar"]) (Some ["foo", "bar"])
check "Universal inequality with Text: composite" do (Some ["foo", "bar"]) !== (Some ["foo", "baz"])
text.ord.tests = do
check "Text ordering (1)" do "a" > ""
check "Text ordering (2)" do "" < "a"
check "Text ordering (3)" do "ba" > "b"
check "Text ordering (4)" do "b" > "ab"
check "Text ordering (5)" do "ac" > "ab"
checkEqual "Universal ordering with Text (1)" (Universal.compare "a" "") +1
checkEqual "Universal ordering with Text (2)" (Universal.compare "" "a") -1
checkEqual "Universal ordering with Text (3)" (Universal.compare "ba" "b") +1
checkEqual "Universal ordering with Text (4)" (Universal.compare "b" "ab") +1
checkEqual "Universal ordering with Text (5)" (Universal.compare "ac" "ab") +1
checkEqual "Universal ordering with Text (6)" (Universal.compare "abc" "abc") +0
text.ops.tests = do
checkEqual "Text.++" ("" ++ "ab" ++ "cd" ++ "") "abcd"
checkEqual "Text.take (1)" (Text.take 0 "abc") ""
checkEqual "Text.take (2)" (Text.take 2 "abc") "ab"
checkEqual "Text.take (3)" (Text.take 3 "abc") "abc"
checkEqual "Text.take (4)" (Text.take 100 "abc") "abc"
checkEqual "Text.take (5)" (Text.take 3 "") ""
checkEqual "Text.drop (1)" (Text.drop 0 "abc") "abc"
checkEqual "Text.drop (2)" (Text.drop 2 "abc") "c"
checkEqual "Text.drop (3)" (Text.drop 3 "abc") ""
checkEqual "Text.drop (4)" (Text.drop 100 "abc") ""
checkEqual "Text.drop (5)" (Text.drop 3 "") ""
checkEqual "Text.size (1)" (Text.size "") 0
checkEqual "Text.size (2)" (Text.size "abc") 3
checkEqual "Text.uncons (1)" (Text.uncons "") None
checkEqual "Text.uncons (2)" (Text.uncons "a") (Some (?a, ""))
checkEqual "Text.uncons (3)" (Text.uncons "abc") (Some (?a, "bc"))
checkEqual "Text.unsnoc (1)" (Text.unsnoc "") None
checkEqual "Text.unsnoc (2)" (Text.unsnoc "a") (Some ("", ?a))
checkEqual "Text.unsnoc (3)" (Text.unsnoc "abc") (Some ("ab", ?c))
checkEqual "Text.repeat (1)" (Text.repeat 0 "") ""
checkEqual "Text.repeat (2)" (Text.repeat 3 "") ""
checkEqual "Text.repeat (3)" (Text.repeat 0 "abc") ""
checkEqual "Text.repeat (3)" (Text.repeat 10 "xy-") "xy-xy-xy-xy-xy-xy-xy-xy-xy-xy-"
checkEqual "Text.reverse (1)" (Text.reverse "") ""
checkEqual "Text.reverse (2)" (Text.reverse "abc") "cba"
checkEqual -- The string is long enough to test the chunking structure
"Text.reverse (3)"
(Text.reverse (Text.repeat 256 "abc" ++ Text.repeat 256 "def" ++ Text.repeat 42 "ghi"))
(Text.repeat 42 "ihg" ++ Text.repeat 256 "fed" ++ Text.repeat 256 "cba")
checkEqual "Text.toUppercase (1)" (Text.toUppercase "") ""
checkEqual "Text.toUppercase (2)" (Text.toUppercase "abcABC123{({})}.") "ABCABC123{({})}."
checkEqual "Text.toLowercase (1)" (Text.toLowercase "") ""
checkEqual "Text.toLowercase (2)" (Text.toLowercase "abcABC123{({})}.") "abcabc123{({})}."
checkEqual "Text.indexOf (1)" (Text.indexOf "" "hello") (Some 0)
checkEqual "Text.indexOf (2)" (Text.indexOf "l" "hello") (Some 2)
checkEqual "Text.indexOf (3)" (Text.indexOf "lo" "hello") (Some 3)
checkEqual "Text.indexOf (3)" (Text.indexOf "elo" "hello") None
text.conversion.tests = do
checkEqual "Nat.toText (1)" (Nat.toText 0) "0"
checkEqual "Nat.toText (2)" (Nat.toText 10) "10"
checkEqual "Nat.toText (3)" (Nat.toText 1039) "1039"
checkEqual "Nat.fromText (1)" (Nat.fromText "0") (Some 0)
checkEqual "Nat.fromText (2)" (Nat.fromText "a8f9djasdlfkj") None
checkEqual "Nat.fromText (3)" (Nat.fromText "3940") (Some 3940)
checkEqual "Nat.fromText (4)" (Nat.fromText "-3940") None
checkEqual "Nat.fromText (5)" (Nat.fromText "1000000000000000000000000000") None
checkEqual "Nat.fromText (6)" (Nat.fromText "1.5") None
checkEqual "Nat <-> Text roundtrip (1)" (Nat.fromText (Nat.toText 123)) (Some 123)
checkEqual "Int.toText (1)" (Int.toText +0) "0"
checkEqual "Int.toText (2)" (Int.toText +10) "10"
checkEqual "Int.toText (3)" (Int.toText -1039) "-1039"
checkEqual "Int.fromText (1)" (Int.fromText "+0") (Some +0)
checkEqual "Int.fromText (2)" (Int.fromText "a8f9djasdlfkj") None
checkEqual "Int.fromText (3)" (Int.fromText "3940") (Some +3940)
checkEqual "Int.fromText (3)" (Int.fromText "-3940") (Some -3940)
checkEqual "Int.fromText (4)" (Int.fromText "1000000000000000000000000000") None
checkEqual "Int.fromText (5)" (Int.fromText "-1000000000000000000000000000") None
checkEqual "Int.fromText (6)" (Int.fromText "1.5") None
checkEqual "Int <-> Text roundtrip (1)" (Int.fromText (Int.toText +123)) (Some +123)
checkEqual "Int <-> Text roundtrip (2)" (Int.fromText (Int.toText -123)) (Some -123)
checkEqual "Float.toText" (Float.toText 1.1) "1.1"
checkEqual "Float.fromText (1)" (Float.fromText "1.5") (Some 1.5)
checkEqual "Float.fromText (2)" (Float.fromText "Hello world!") None
checkEqual "Char.toText" (Char.toText ?a) "a"
checkEqual "Text.toCharList: empty" (Text.toCharList "") []
checkEqual "Text.toCharList non empty" (Text.toCharList "abc") [?a, ?b, ?c]
checkEqual "Text.fromCharList: empty" (Text.fromCharList []) ""
checkEqual "Text.fromCharList: non empty" (Text.fromCharList [?a, ?b, ?c]) "abc"
checkEqual "Text ut8 roundTrip" (fromUtf8 (toUtf8 "Hello, World!")) "Hello, World!"
text.debug.tests = do
checkEqual "Debug.evalToText (1)" (Debug.evalToText 3) "3"
checkEqual "Debug.evalToText (2)" (Debug.evalToText "hello") "\"hello\""
catchMsg p = match catchAll p with
Left (Failure tl msg v) -> msg
_ -> "Success!"
checkEqual "bug (1)" (catchMsg do bug 3) "builtin.bug"
checkEqual "bug (2)" (catchMsg do bug "hello") "builtin.bug"
checkEqual "todo (1)" (catchMsg do todo 3) "builtin.todo"
checkEqual "todo (2)" (catchMsg do todo "hello") "builtin.todo"
check "Debug.trace" do
Debug.trace "First message " 3
Debug.trace "Second message" "hello"
true
checkEqual "Debug.watch" (Debug.watch "Watch" 3) 3
text.term.tests = do
check "Link.Term.toText works for ability constructors" do
match catchAll '(Link.Term.toText (termLink abort)) with
Left f -> false
Right _ -> true
text.matching.tests = do
check "String literal matching: empty" do
match "" with
"" -> true
_ -> false
check "String literal matching: non empty" do
match "example" with
"example" -> true
_ -> false
check "String literal matching: default" do
match "example" with
"" -> false
_ -> true
use Pattern many or run isMatch capture join replicate
use Text.patterns literal digit letter anyChar space punctuation notCharIn charIn charRange notCharRange eof
checkEqual "Pattern api (1)" (run digit "1abc") (Some ([], "abc"))
checkEqual "Pattern api (2)" (run (many letter) "abc11234abc") (Some ([], "11234abc"))
checkEqual "Pattern api (3)" (run (literal "abc") "abc") (Some ([], ""))
checkEqual "Pattern api (4)" (run (many punctuation) "!!!!,,,...") (Some ([], ""))
checkEqual "Pattern api (5)" (run (charIn [?0,?1]) "0") (Some ([], ""))
checkEqual "Pattern api (6)" (run (notCharIn [?0,?1]) "0") None
checkEqual "Pattern api (7)" (run (many (notCharIn [?0,?1])) "asjdfskdfjlskdjflskdjf011") (Some ([], "011"))
checkEqual "Pattern api (8)" (run (capture (many digit)) "11234abc") (Some (["11234"], "abc"))
checkEqual "Pattern api (9)" (run (join [many space, capture (many anyChar)]) " abc123") (Some (["abc123"], ""))
checkEqual "Pattern api (10)" (run (join [capture digit, capture digit]) "12abc") (Some (["1", "2"], "abc"))
checkEqual "Pattern api (11)" (run (capture (many (charRange ?a ?z))) "hi123") (Some (["hi"], "123"))
checkEqual "Pattern api (12)" (run (capture (many (notCharRange ?, ?,))) "abc123,") (Some (["abc123"], ","))
checkEqual "Pattern api (13)" (run (capture (many (notCharIn [?,,]))) "abracadabra,123") (Some (["abracadabra"], ",123"))
checkEqual "Pattern api (14)" (run (capture (many (or digit letter))) "11234abc,remainder") (Some (["11234abc"], ",remainder"))
checkEqual "Pattern api (15)" (run (replicate 0 1 patterns.letter) "123") (Some ([], "123"))
checkEqual "Pattern api (16)" (run (capture (replicate 5 7 patterns.digit)) "1234567,abc") (Some (["1234567"], ",abc"))
checkEqual "Pattern api (17)" (run (capture (replicate 4 4 patterns.letter)) "aaaab123") (Some (["aaaa"], "b123"))
checkEqual "Pattern api (18)" (run (capture (replicate 1 5 (or digit letter))) "1a2ba aaa") (Some (["1a2ba"], " aaa"))
checkEqual "Pattern api (19)" (run (capture (replicate 0 1 (join [literal "a", literal "b"]))) "ac") (Some ([""], "ac"))
checkEqual "Pattern api (20)" (run (join [many letter, eof]) "aaaaabbbb") (Some ([], ""))
checkEqual "Pattern api (21)" (run (join [many letter, eof]) "aaaaabbbb1") None
checkEqual "Pattern api (22)" (isMatch (join [many letter, eof]) "aaaaabbbb") true
checkEqual "Pattern api (23)" (isMatch (join [many letter, eof]) "aaaaabbbb1") false
checkEqual "Pattern api (24)" (isMatch (join [literal "abra", many (literal "cadabra")]) "abracadabracadabra") true
checkEqual "Pattern api (25)"
(run (captureAs "goodbye" (literal "hello")) "hello")
(Some (["goodbye"], ""))
char.class.tests = do
check "Char.Class: any" do Char.Class.is Class.any ?a
check "Char.Class: any (2)" do Pattern.isMatch (Text.patterns.char Class.any) "a"
c: Nat -> Char
c n = Char.fromNat.impl n
run class y n =
ok = Char.Class.is class
ok' = Pattern.isMatch (Text.patterns.char class) << Char.toText
ok y && not (ok n) && ok' y && not (ok' n)
check "Char.Class.alphanumeric (1)" do run Char.Class.alphanumeric ?a ?-
check "Char.Class.alphanumeric (2)" do run Char.Class.alphanumeric ?3 ?-
check "Char.Class.upper" do run Char.Class.upper ?A ?c
check "Char.Class.lower" do run Char.Class.lower ?a ?C
check "Char.Class.number" do run Char.Class.number ?3 ?z
check "Char.Class.punctuation" do run Char.Class.punctuation ?! ?p
check "Char.Class.symbol" do run Char.Class.symbol ?£ ?s
check "Char.Class.letter" do run Char.Class.letter ?l ?3
check "Char.Class.whitespace" do run Char.Class.whitespace ?\s ?f
check "Char.Class.control" do run Char.Class.control (c 20) ?f
check "Char.Class.printable" do run Char.Class.printable ?f (c 20)
check "Char.Class.mark" do run Char.Class.mark (c 769) ?f
check "Char.Class.separator" do run Char.Class.separator (c 160) ?f
check "Char.Class.not" do run (Char.Class.not Char.Class.letter) ?3 ?c
check "Char.Class.and" do run (Char.Class.and (Char.Class.printable) (Char.Class.whitespace)) ?\s ?a
check "Char.Class.or (1)" do run (Char.Class.or (Char.Class.letter) (Char.Class.number)) ?3 ?!
check "Char.Class.or (2)" do run (Char.Class.or (Char.Class.letter) (Char.Class.number)) ?a ?!
check "Char.Class.range (1)" do run (Char.Class.range ?a ?c) ?a ?d
check "Char.Class.range (2)" do run (Char.Class.range ?a ?c) ?b ?d
check "Char.Class.range (3)" do run (Char.Class.range ?a ?c) ?c ?d
check "Char.Class.range (4)" do run (Char.Class.range ?a (Optional.getOrBug "testing non-literal chars" (List.head (Text.toCharList "c")))) ?c ?d
check "Char.Class.anyOf (1)" do run (Char.Class.anyOf [?a, ?b, ?c]) ?a ?d
check "Char.Class.anyOf (2)" do run (Char.Class.anyOf [?a, ?b, ?c]) ?b ?d
check "Char.Class.anyOf (3)" do run (Char.Class.anyOf [?a, ?b, ?c]) ?c ?d

81
unison-src/builtin-tests/tls-chain-tests.u
View File

@ -1,81 +0,0 @@
-- more complex certificate scenario, with a root CA,
-- an intermediate CA, and a website (registered as "example.com")
-- more complex certificate scenario, with a root CA,
-- an intermediate CA, and a website (registered as "example.com")
siteKey = "-----BEGIN PRIVATE KEY-----\nMIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQC/gjZrabSInd+J\n+lZmWW/qdDGRrMFyzE2n2rTfZ0ueszZb9lTZIHl4xPsN1hvP/wd48Dy+t9Dmp3LH\npxPVT7LXPGiTgkmQzaRwPa1cos6FYwbRb2lC7GnT9BueXNUvl5DhyHsl+E4DDRwL\nb51GYRiCouSqDuuMLSAA2nVD/8AHwYRAQciaShji6EShJPpFaipq5A20Vp8tW509\nlaRqSYbRbLUsiiboisrOV1600vyxCQUT9MyRwqEm25mrNeuf7fKSdhRmhjSBGBZ7\nHT12OxuPqpl5b0TroTZRBQfFUnM1kCvZS/uK+SvWm8C9/nUzS0z0xum2XS08c1VG\nbTxZMF6zAgMBAAECggEAWDm0uGdKNGYGxZn+k8hANtKww1vDAw/79ohbK1B7FfGZ\n6WPiUuUTEQAuaIFq7reeyahjU7l7E8ewqSnfiTXePiomQ06SdZNHXi4L39FhMzIb\nwgCBjcM8PdkHoD1EOVip9lpV4Xgy+FThxqL04ad5kzVYAsA846cmRz5dJ6Z64RcJ\npGdxENMGqfOKPf4ZJMaU3J7zqlyWaixWG1p0mU079LjMsumCHhE9QJ6XIStgf+RE\nhe+U6UVPE0v+zxrSCrfLpFzuEeNONsl91umxcabV9C0sohd0o7LsEZgj1u62HWSx\nXUnuCE/zbWvkPF8jAUebYfOE9bxW86O0PLCffawCAQKBgQDlJ0CDEaOfb9j+okkq\n5AfDzV7Ci3yR9CVktWeH1vLHhaui507wTL1vs5pyhjZ+bs63zt58uLHMKJtKmX37\nA0UnpCVHg+BYV/UzLhFZGtXxzbABPosdfJ/+M+cYXDyQ68dleAU6DB+2b1FCbzwq\nDu8Wmnn5E0g8P3HROPEgIIPZ4wKBgQDV8eyaqU+V1D64e98BapyntRgUrc0oKdu6\n10Sh5wdWrnpguKEw2K/0zBZlVUEtK812BL9CNNMIm8zXDBMY24ZHo8NH8Y8z/G/o\nC7pJVNAjbHu9rglE6f0mtdcSa4F9yx37rfeRLgKZ628+nFSucgGdyL3BNiG40rlG\ndRd6qKLA8QKBgHPQDLixV4Ki4oZ+un/k00/QIY4tNP4G6Ecnr3Vl2zmfgwlH4gts\nnWkw2mP7FNt9YRhggu2B4soN0742KQeNtYu9V+H28pFzkscVB0uDVpFopQVb+K8k\nZy/wR2F2bF3J6/KKYAngSr7HL8hls4CGH6vK0s5hQmbAoeNd5e+Yv0qFAoGAQkuZ\nGcPlWXRPizM3Q2UZ7g37zEyfChcOc7NJHTJN39ppKZeMu2op/B1Rw0zLyYeNP0jx\nSz67NiuxKeIf+M/tqD1iweRkj6Nlue4IZ7jUVmXDYl+Pl786JsiqQJb3pVdPjzG1\nSVOMks2Vxz0CMJw7S/1sb3aqtG734pFeGTAwXsECgYAX5Fpbqwi0N26jkCSa4oYy\nKxVO0DfAcA51oYaQ/Pwreq1zOKv1xL2b6EeNmtSVvCSr7Ee8cBsPG+gPF3OJACQQ\navwixN1uJhO9nDrSgTcLCZzLPT/GIOjOTBIR1dlQg76+CkCdjc/Ip4opLoSn8cP1\nTAlVfAt2xOabNxk0gFEDpg==\n-----END PRIVATE KEY-----\n"
-- site certificate, example.com
siteCert = "-----BEGIN CERTIFICATE-----\nMIIEWDCCAkCgAwIBAgIBATANBgkqhkiG9w0BAQsFADBCMQswCQYDVQQGEwJVUzEL\nMAkGA1UECBMCTU8xDzANBgNVBAoTBkV4Um9vdDEVMBMGA1UEAxMMaW50ZXJtZWRp\nYXRlMB4XDTIzMDMyNzE1MDQ0NloXDTMwMDYyODE1MDQ0NlowNTELMAkGA1UEBhMC\nVVMxEDAOBgNVBAoMB0V4YW1wbGUxFDASBgNVBAMMC2V4YW1wbGUuY29tMIIBIjAN\nBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAv4I2a2m0iJ3fifpWZllv6nQxkazB\ncsxNp9q032dLnrM2W/ZU2SB5eMT7DdYbz/8HePA8vrfQ5qdyx6cT1U+y1zxok4JJ\nkM2kcD2tXKLOhWMG0W9pQuxp0/QbnlzVL5eQ4ch7JfhOAw0cC2+dRmEYgqLkqg7r\njC0gANp1Q//AB8GEQEHImkoY4uhEoST6RWoqauQNtFafLVudPZWkakmG0Wy1LIom\n6IrKzldetNL8sQkFE/TMkcKhJtuZqzXrn+3yknYUZoY0gRgWex09djsbj6qZeW9E\n66E2UQUHxVJzNZAr2Uv7ivkr1pvAvf51M0tM9Mbptl0tPHNVRm08WTBeswIDAQAB\no2YwZDAdBgNVHQ4EFgQUS34Lu4VpXUCCre6QxCAZdyAzgN4wHwYDVR0jBBgwFoAU\n27OdzRI7IREkMewS5n+F4ovzl/4wEgYDVR0TAQH/BAgwBgEB/wIBADAOBgNVHQ8B\nAf8EBAMCAYYwDQYJKoZIhvcNAQELBQADggIBAGBkXgWoAzum/f/VgJWKPt8Bo9Dy\nLYjckSbaQcw0YmgXLzJn71QTD+jvSbGRT2tYSkgCVOlVLzHV6mtgC/tR7gfKWmkx\nEhnTdzGQ3G/y03+c2newwkDrvT35/4BLlsrJv/19/LIc6OJ0/BJOBIeb4dZGmo2N\nH0qgIvjpuV9BAzwc7euENob0K2jkhFTUi5WmXMBzT2besc1T9iGz0wUpn5osGc/7\nCVcEPdvrwOLfi7jqhxC7tTzbZO8qu7MmmqaSx4UbDVM84652HTbDpSbEeHeD122D\nJcAFE8ouoDKRttxk+N9yT6lBzJIV8UmkabDiymceQ8fmh2CsIog/aodskLszcUHL\nlqc2KOAe6qVEc+vVLBj3/Duqy7F+Z0f/S/s1hbRawW95bJJJOFhHW5wErCPlKH0O\ndzNxC/mmAEuf39JAm9K1Pbi4dr92rck8C9llp/xyUUT7gIkZx562RmkBftcf3+29\nQe7MJGTHHN1FXfVK/F7C6pFeSVogeR28klCnD2LnrFFvdFtLa9uht2o82dPXN88B\nDMVCPgP1hUvXWkPEdKol69zMxQf8GANHWLGpJaoqcsVGmwHaitpeCMCwrtDi0Y91\nvrL+QoXpJPd5FaDdQHo+Pln7O6hU6euzVibi9WdAFxs1w/neWhyzJbUcJZ70aHPM\n77PNweTWNCaNkP+Y\n-----END CERTIFICATE-----"
-- intermediate certificate
intermediateCert = "-----BEGIN CERTIFICATE-----\nMIIFXTCCA0WgAwIBAgIBATANBgkqhkiG9w0BAQsFADA6MQ0wCwYDVQQDEwRyb290\nMQ8wDQYDVQQKEwZFeFJvb3QxCzAJBgNVBAYTAlVTMQswCQYDVQQIEwJNTzAeFw0y\nMzAzMjcxNTAxMTNaFw0zMDA2MjgxNTAxMTNaMEIxCzAJBgNVBAYTAlVTMQswCQYD\nVQQIEwJNTzEPMA0GA1UEChMGRXhSb290MRUwEwYDVQQDEwxpbnRlcm1lZGlhdGUw\nggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCuBOyOUa/oleaNPAZ0qVS9\nYABi+FNeflM7dmRMIq01m8qiIaVV9dNl4jgHYMq7iBhZU+re1hFq1J+d4wDMctDj\nH8KreEmOSYiAqI9n4/g//Y5z+QeMEcIjqppyVCVQqvXOYzvHHS/bvObKF2cs+FRc\nURWIXM99D7/IgqiyGilhjWLqd8pLOWs58MjZyEBdJlS7NTFJDFKsK8EvrPMwVVx6\nVUZaCJyTdK0ZtbA/eNEJk76LTSA9+WqIbDqrWjhP3j0DVg9CdFCJvvdiSNHpw8W8\nCC3V1r3+J8rK9zSYYmV6Yvn1sDVJX2CnPvnFJrjsGiROpzwd5zo3K190shjAAsHG\ngJokSahQtwKVz8vaCLb/hIGPa1GWonSTqaNCcWI3pH9GWuZXFVFxuw/FNDmUU9eN\ndMxXTx64huX+FpDx5NZYre9W/Gb0VYIPRdVF/vWswmW1i1Zz9NZrP00X9IRFimjM\nOHVwJ1NaTnGzg/uu8SbzKc9pc+zocdJwMqiwICHbcIN4JTDYwDsbTS/moJUk+oJw\n5OiL1KZQ4HoTCJpmx1nVZocMVQuajEILyEDiRF3h670TNNnkfoFcPnM293IMWPwX\neC5MoADlpzMpTeHcdlkIkgw9/1ainOGYa1B+1d7/V07Tfq2nOKQUY/4Z/WeLEhPm\nfjF9C333Yz6MLlGN8DMKawIDAQABo2YwZDAdBgNVHQ4EFgQU27OdzRI7IREkMewS\n5n+F4ovzl/4wHwYDVR0jBBgwFoAUY2dM5JVlK9JVFFb3mZrJXd1YO8owEgYDVR0T\nAQH/BAgwBgEB/wIBADAOBgNVHQ8BAf8EBAMCAYYwDQYJKoZIhvcNAQELBQADggIB\nACkow/OmLPd2DzrsBhDvlGQ29ZYKuvGCVFlT0PSWFbu+5DD2HFrKffaBTeuEAY2k\n3d8HJE7CtyxOSl5vFDSfr9si4EmvFeWN0d+2n3AGLUxxC18XsW6ctTnQkpvcOMEk\nm9Opu6q4JNWP+iWle9U3+RC8suotWc1trGBk1y7yHfFmqim1aoxygS1xUpo1j/8L\n+W00sxprog48E0tQ2/AML+yKmXwt5QapO3e0UIoOkYaSyapk+K3KymvCFmwsU/7Q\n0+KJBiCS4HXUFe5iWpnoCuLL18o1gO6LPW9nBB6EIKnmcsZNt/Z9KRMoQeBS+eRY\nGOxxJwdyzDJAFEKPhIO4xrZtG505Ea73nm6NqoRYUERLDBUFY1BnECcBKqSZmmVi\n4zNQj5d6sevliLx/V3LDa/BPkHjDalHgZxEEkTCGfppTYC5oAB4eOwJWhpM+n2gM\n18gmbmN7ECUWw9jvQrKMGepp4s9ggtf6gyqqCvMtfP9i25OGX860VcvxCV7yqjjh\n58Nwkn5WK9ZnUXZLb9h34KjKenxzlXad+j761OpQ3fh9DuK1H0EmdrkPgnHCUT+3\nEWM+rtnhl/XAZ453InJXdG0yiGgM0uoXDHi8iuVaBkOiY27e6jg9LPg6zq3Kju6C\nVzlYLIwqPf6AAPL+ugUbnH/zNfy6JXdDlufQ/ZcFLjLj\n-----END CERTIFICATE-----"
-- root (self-signed) certificate
rootCert = "-----BEGIN CERTIFICATE-----\nMIIFSjCCAzKgAwIBAgIJAJBvc61E2pT1MA0GCSqGSIb3DQEBCwUAMDoxDTALBgNV\nBAMTBHJvb3QxDzANBgNVBAoTBkV4Um9vdDELMAkGA1UEBhMCVVMxCzAJBgNVBAgT\nAk1PMB4XDTIzMDMyNzE1MDA0OVoXDTMzMDMyNDE1MDA0OVowOjENMAsGA1UEAxME\ncm9vdDEPMA0GA1UEChMGRXhSb290MQswCQYDVQQGEwJVUzELMAkGA1UECBMCTU8w\nggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQDOeole9DHTycMh669FgRUw\ngch3RAb3TPhN9mwEnnIb7WhaUU+wltpImedYbUBrh89w+eF34OZ3yIXvdpKv3ihI\na8ucZDCGJK4mPw0UKLfBoplGM0u+eXMFQsX08OvZmGf1kTkIlhOkSpIwZK8N1Dn8\nVmOs1t1xSdxecJ8cc+3IE25qCRE66x0g175XkoZ0At5M2ZlzWBP00H2N1cXpXbIb\nZ7IdsMRtI00WI3f/MMFasFhTO9c/8iRNjLsoCuOIUDjy8m4AGX0tPmV6FQV6WMNA\ng+6U+rkWo4wdxbQhAbfMQHIU9wm0Tj0lXAh7ma3zlIbaZjG6EEZWGUOedknf+IfO\n2VGR3T9WoTyfNGIOqBHtKhDiB0PcPa5mw+KsN1UycFvIxH6aJkXq04nnnZkNEFNd\n7F0jhPt6O0K14y08yEmZqT1HJQCHQdEierDQo+u7R0sJ4zTlDxogvVyftPWtgXYk\nd6OfWgS1Qk/qRrtRnLtf13dkv0ia7Ndr2Ua5j4T80StIxyoFNUKHOelep7iO33E7\nHjCcuNVPdeOZSmLzUjwu5DSKQnHyHXlIrktgPNDTAzhx2WGr84Fs4jMKXrntjRM2\n7P0k/70ZUM7R5jbgVvnTQAl7y5+oWWySw7Oigrme0PDP0ZESVMeNl1NcxnqtLO8l\nbaVTVFtB/dz3VP1J0om51QIDAQABo1MwUTAdBgNVHQ4EFgQUY2dM5JVlK9JVFFb3\nmZrJXd1YO8owHwYDVR0jBBgwFoAUY2dM5JVlK9JVFFb3mZrJXd1YO8owDwYDVR0T\nAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAgEAYd0hcSjSBhUCdibKdLbzglyq\nSYeQlSEuqmeNQDpDVbnWTsPK+LQ66Nj1kAuITWdpdn9wnA1Gp2P45PR1sc7d1eI6\nj4NvoOQMSwZtxt+3+ZncZMBf96VZwdX5v3ydk3pZy0KhwiKI/aaHRU5WneibLs+F\nisBUlUNolALPMgmV47gN/jlGqZRrHi1cOZVLs10q9p5TMEm1JuFOAjk3RINo2EzE\nz3oA4CtC+8wmKi0SqvQF1wxV1fJXh4oTXYCaq6feFBsTqUYpA9GjciYH4h/Ihe2/\nSBhBXSYXcMdamglZwsKnVZ7zqkhJlARQC0NnSwmVK4B6vIlm0ImEcsRFwo/6xmML\nZu8EQAu7h3cSS6p9ghHqeuKgEltiiNVCvJim/9R6Z9DjdVQJnPnDtTofKoCkmgVE\nFe7hGIKdrFmP0zKRPAiUuaHLDsvayUUsFAgc3bGr8YPPTwCtk5RlRAdwofsliAN0\n5FIkDM2ftCc1Kh4mE3HBoB5JYhH9WqhoeDlCpp242RxiVVsmgPxkGaEIzL7Q0/X8\nIFrhTaIWPPsF9PJtwswEePGO56tIXaQTV9ct3vfYIxrJp+iG11wqRn8FgFset17V\n/MMsxyRqBDCznAykoViCFrfolZpjcdtVr/m9vVhR4YkUZlG8VDi7BTD6AaDEBkOM\nImFGWriD+Irt4Ubr/D4=\n-----END CERTIFICATE-----"
-- root key
rootKey = "-----BEGIN RSA PRIVATE KEY-----\nMIIJJwIBAAKCAgEAznqJXvQx08nDIeuvRYEVMIHId0QG90z4TfZsBJ5yG+1oWlFP\nsJbaSJnnWG1Aa4fPcPnhd+Dmd8iF73aSr94oSGvLnGQwhiSuJj8NFCi3waKZRjNL\nvnlzBULF9PDr2Zhn9ZE5CJYTpEqSMGSvDdQ5/FZjrNbdcUncXnCfHHPtyBNuagkR\nOusdINe+V5KGdALeTNmZc1gT9NB9jdXF6V2yG2eyHbDEbSNNFiN3/zDBWrBYUzvX\nP/IkTYy7KArjiFA48vJuABl9LT5lehUFeljDQIPulPq5FqOMHcW0IQG3zEByFPcJ\ntE49JVwIe5mt85SG2mYxuhBGVhlDnnZJ3/iHztlRkd0/VqE8nzRiDqgR7SoQ4gdD\n3D2uZsPirDdVMnBbyMR+miZF6tOJ552ZDRBTXexdI4T7ejtCteMtPMhJmak9RyUA\nh0HRInqw0KPru0dLCeM05Q8aIL1cn7T1rYF2JHejn1oEtUJP6ka7UZy7X9d3ZL9I\nmuzXa9lGuY+E/NErSMcqBTVChznpXqe4jt9xOx4wnLjVT3XjmUpi81I8LuQ0ikJx\n8h15SK5LYDzQ0wM4cdlhq/OBbOIzCl657Y0TNuz9JP+9GVDO0eY24Fb500AJe8uf\nqFlsksOzooK5ntDwz9GRElTHjZdTXMZ6rSzvJW2lU1RbQf3c91T9SdKJudUCAwEA\nAQKCAgAyZxstgLLBHllx6FSKxO3lP2kuI/8HU1Sxw1uu7Pax9owor/yiANEcM+WT\nYmf9V9O9omH1n4Li7qIzSGCaacKvmxDDBnoJ5N5WG8IXj7D7pbOAvXjZ8E+xkxE7\nr6wDG/8UpPSlMe1th36ULZ/F4m6dOIFwaar4wqz2qMtOaMY8tvGXFMuN9GLR55hh\nTDViEGkvnVamH3QPqO1dODfttZ+KrQ9/y+zHL3zb0KC0PLSWbMHC37K1u2g9PgNZ\nzP6qAdtFAwTzJUW3S6n92S/TI+PV1d7hoyqXaikEA4TrIb46L+kpUPyfdRHcEtFH\nSsZ51WHt4lB1OQ/SaKxm/D0gXUzZMrQ6IWz0r3qCrX9PxOmLYs5xWIe2mU+Igd2H\nnfnJB9XX3i8uuppCIOUncnh9jicR3qwSxiVc3irpV8+42KqTWbJLLlXo4i6bDoQH\nHdWp5bAYouWkCotoFKGRGU01OsUca+Fu+k3e+w0IfI2oO5yS05X9jhzCMjoUxg/d\ngcSdrttqcu1m23CDahnthZ95C3HlbAXj1hGDAxrePOg8GC/avi6EJnRS28hvIOVo\n825U14Qi0317328r1GROnA94qw2z7HYKh6r/d8jVYG1YNLdgfUP80UIFVR6XKVW4\nWuxFgwrcQ38Bpyj6+tXuLROWO5s6McgjxGq/AtA/ixVFg9CI6QKCAQEA/9VJbXue\n+51hY++m9KM84JmcTzakOJw9znCPqak927A9WTUiPiRTUXB4/RJOXS5xht2zGQB4\nihfOfv7AGvKGq0xAbvFeb1KK1C6S7lut8u58jyy+HQO73NV4mEEkE85JD9P4TuLT\nFQHRaCZQTg82TnSl/8MW0WuwhDvk9qHaElXzBmCl1IburKxtHU+X5EkyfVWuJyRI\nkY9KLuaBwe1+EG9+wZJyr5sESPTZSKfqULBkjFnTuJu6OMGSXWC8eWvtwSQhv/DW\n9HPWmWXg9NJ+lGTvz3N9jgjU2RzhAdqtrNpW3t9UoI0O4/OKgdAidC+7zXcmDNoV\njxUYK63UZyc2RwKCAQEAzp0CezyQDRJjrMM6F3SzWo8MgyHPs8+H1AhxTtNN4ML5\n7a+9EiL9AaWSekAkyEHCOCYoJzvUmx7QbtJmpvLWXz1HF9iSuNXhJUqPWoflNPc4\n4sPnkyP0KIrmzVzF+vKp0MEsR8Qv7pO2l3+1ub63scVPqR0dMs+yPaMcxaisVs2B\nThYvhLciORwtbWYCfOKy/KdX/a72HKiFpVHcvQSN+WsTjYn+e7y+kNrVisg4dCwI\n9E+DBU5MeuhAaI9c4cDXZPm0dcOhyL+FBm2VQdYV1hq8e7HvN4AXyOgVP2FygxoJ\nN2L19uH4OQpav8oTrgDEmNBpkOGsvmsmgkzruIuxAwKCAQBkateTfb59jNy5WUvz\nIk+26RSNkykKf2lTKqN5ONDq9lZeOZjjQ2bgxID49MKFmME+6q5t1d16drW660uE\nSEXL3vY7lco3b/LGLjHGFX5FqI6DtFA7G0gV+kSHnqoGjCXpbI4+iJHJ4RjNBJzo\nxtfOG8M8jNrcAKUcglXw6L6sC8iEbFMrBHuSk2uQ4bkBBionQAZHntpNKC06E4hD\nEnE1Ck56tH0HqJUZ/eF7v00dtt8AqBGOmLGTrYdB18Ki9lYwRXpp2KLG+OD2/SI7\ndpPws13d07sokRba0ZcQH0GkY19Nw+N30WZS2zk2kvezGzlgALCSwtdLfkAqhOSm\nSKHpAoIBAH03Ppe9XnftmybKslwgx8msRCL8zMnmjiT8cN8axGnhAGMCTI2/UqI6\n3Ajm8uPCppgs18zfP7w68osXTEsFhNH3ayySfmkyhd55z2NIVKrC4WDc5W2RLpmb\nhMEU5o9tnWj8iX988KegMdqi9Vl6sg00zVBqapWuthEQ15Ea5kc9CI5wd5/w9Paz\nkvxoBD33jg38xSDjdhhsMYK9mA+dwQVV1WXEKcyH2N4lIaGYMk6FmW+m+Hqwtz0N\noGs950aR/ngdtTZht5zYJSB+LSTXQCifz3cPoTB7mu6RaL8eqa22i7tbaEGVNUAs\nfE8bgs3DfWI3fKLngi9s9MunHnybfE0CggEADkWhhMkrhiz67DxY1zQiUl3n6/aj\nsyjMPth1tqsEPWAGBMuwl1Wj60QlsXoJ7FH1mFLcU2cKdOCNQl9CKLC8XNwZ2Ahj\npGnJ1A1LQ3z+87aHcRXDvQr98fg77uOX6KUX4NMrBlzfUatN9OWjj3pLuJ8+XasV\nXKsOKJJZA4icTORfZ+AuRbNVfu5VJ2gejku5m/1Hp6LgJXUUrgbpoLYoyWrtXlY4\nuO05svUtdwceP0QzL+oVZU03I/BNcCuXZidaZvG5v22De8ZBIOQlLNHMXVnnTUUX\nYfJSdqQDgZXzvwMljmnbl9DtWY38FozRpOpHs0cf9gjA73RAsm/eRSeMsQ==\n-----END RSA PRIVATE KEY-----"
-- intermediate key
intermediateKey = "-----BEGIN RSA PRIVATE KEY-----\nMIIJKAIBAAKCAgEArgTsjlGv6JXmjTwGdKlUvWAAYvhTXn5TO3ZkTCKtNZvKoiGl\nVfXTZeI4B2DKu4gYWVPq3tYRatSfneMAzHLQ4x/Cq3hJjkmIgKiPZ+P4P/2Oc/kH\njBHCI6qaclQlUKr1zmM7xx0v27zmyhdnLPhUXFEViFzPfQ+/yIKoshopYY1i6nfK\nSzlrOfDI2chAXSZUuzUxSQxSrCvBL6zzMFVcelVGWgick3StGbWwP3jRCZO+i00g\nPflqiGw6q1o4T949A1YPQnRQib73YkjR6cPFvAgt1da9/ifKyvc0mGJlemL59bA1\nSV9gpz75xSa47BokTqc8Hec6NytfdLIYwALBxoCaJEmoULcClc/L2gi2/4SBj2tR\nlqJ0k6mjQnFiN6R/RlrmVxVRcbsPxTQ5lFPXjXTMV08euIbl/haQ8eTWWK3vVvxm\n9FWCD0XVRf71rMJltYtWc/TWaz9NF/SERYpozDh1cCdTWk5xs4P7rvEm8ynPaXPs\n6HHScDKosCAh23CDeCUw2MA7G00v5qCVJPqCcOToi9SmUOB6EwiaZsdZ1WaHDFUL\nmoxCC8hA4kRd4eu9EzTZ5H6BXD5zNvdyDFj8F3guTKAA5aczKU3h3HZZCJIMPf9W\nopzhmGtQftXe/1dO036tpzikFGP+Gf1nixIT5n4xfQt992M+jC5RjfAzCmsCAwEA\nAQKCAgAX589DYc9jiSwp3MQaRKTCeyyya+CwC3SNp57xopXe1m8IxMx8uY934JLH\n2LEg//owU0nhoNC1t03SF7wlWeR+Pv+0JIseQ9W/rug8YmHZEJEAN4ak5E+iLK6Y\n5BxYL5Qi7RjqKoVHj3S48GwZDmgwYmct22oZiQ9UkTZxeQyUPSMIiLo+iT3EsOI2\noL7OzRQ4v37sxQeaZUxdq0mhKyjQGWTXu3UfAJlC/eWfYo583VIAuvCh8uCCqzOI\nFJXFywbgrXLdMzNZKOW9F7nWfjFsukbpqF1jS74dEcak5GeCX5Rs/u7jDHovn4Qa\nZE5lCNZSA8FLbldd+tRbKJgj0H0j+IsIi72fDp9bigHvXmvYU0TR97dURj4Ih233\ndAOT1xLnPHm/3haTTwA6dzEh9ghYxj2A1MpyT4EC6fv2j9LP3Uj55Np9FxtSPZfK\nhe6QSILcEon9aqXsWjf7cHWOd7C673+IynbipedhsSO6g8MnARujrXXe1wbWr+Jc\nBsOS7klYT0+RhDfrm5XReDYEsE6TqoZBlvFavCEZuoTEa6hSEe3iFpnArkaPx2il\n1YKkPTk7xR8t1ncq+F11K1R+kCVRXbnPzhxr99u3A70Z4/uB7AXzYp0c8yHlfm+a\nLajcG3aKJWPpJ22XvZIDGt/egg31d+B9fmVlSXZPIRszjEoDiQKCAQEA555QLid/\nZqc5IK411iOJCmTmFsz1jU15odUahZ96sTi9ZHHsY2u3l+GxgaR/HrxZOfStEjGL\ntX5sEeZoAm4uO1fq9P8YiDzGGzUzxnSxYv6cZHXr3Y1CaDIQLIHVqddHGnyesJDx\nV+f2toElFk9qHla5kUEYPQ6xqDAn2LVdHlYvVDNU4R+ONPb7NiGuOG7b5kc+5Pqh\nWkw0iGd+VAEzrLaBNxlximMfe3VjgvD0LvBV8Dc33xPe6QI6QVnLJV6vxBlnDyiR\n2gCxtGTxgh8RmH/ly8on59MM7IJjQWWfDTvlSqJ+FiaHaHCNlR4tfr4MzSCh3a65\nNnDNXG847dSzXwKCAQEAwFZreSKBLV69wCnNBSGArpIBfeHstBEoCSf0903ub+KF\nOhoY+jksJS8AhT1xIgvMOftDdzXS0p49Kx0dsgdEsLn3IzuO+2itbj4jSiGMTbZN\nLTAYCf86hdQ1aCfGMuHNcvqohICxkEGx3mn4goEDrWsvwTAHANK1kDafZKNL2lgX\nLb+lQp4Z3JxMWYv6Sfzy08Caq/f1FzsJ3/tu4Qb5aYP++cf7rmD7p9wmsB+fAUH6\nFJTw/ZNhiaLC90b59C4KCZScjAh3KqwAePvG1td/RuUbXOhO6RGZGzHXEpxNB5pg\nmWJa8XKDXfHnmf3cHQESI8YPyW/wGL12ubR57qzwdQKCAQEAxcvlzzR90Q1XdPgx\nE5kvK8g00h3gSPZzu+dACgLChVveKUw8wj63/6WGsB7pTDcuv5aawmG7XJgE9Fhe\nVE0BgD45cVXz/kxgJdYOTBlVbyPeLNCjR4Wdw1uVglyyOaOVniH0ZvawlBCNGRg6\nss3I4vXO7SO47lOBFg9hx+hCCGkza+WWQ9Zt2/9bUsP6g0jw07veEy+R4YoYhrBT\nKqwIFCObP5Gj67lwpj7+Z1EcRoWJ7mVJemD+yN/VHf/vww8UbRQAdeqAe7qCB3r4\n39VmcmQuuxT9dTU/4S4MU0nURTn0OwN/R61Jj8AmuMSXt5fXWMnYUXcnxj0Ysyps\nZHZzYwKCAQB2mdOT0q8NJwqi4CPIMiyDeQzqbtHjB2FEpBruFGQfIfM9LLKSOYb7\nNsx/XK/Saqv4ZPPpIotpzKGzYDTbfpfg0guO8j7s0FOBU1e3cpBtqyhT4QAxyexw\ncbatDzmsToi9ics4SZM0fQ4NNBNFhgCagynjWpY277d9wfDvwbIYZZGFaFOjjJIt\n80MxRJuF3DBwWqgFutSrCoDAWO66W+6YHgiwRZzwnmUP0TUaDaWixOhMoLsp4iOX\nF4JZsK6Y33rZBYay4tV4vq9b6wVlnWSidsw0shtWpL9ggY85rp/hPFSswHWLxS00\nVOKXlm6QhASHgq5hbGEFIG+Be8RkZMexAoIBAE9nDwYPHYqsh38flJf61aKzbrg6\nL9l9DEQFaseVQPavqnTHEUJ2ZzGTsDuduZGvy1PwpKltU2vhWDTqfoNQIf76rfml\n84ZsrPtj1Ea0NYKMOtM/mLQhUDy3XDrNEe8VLu/KnWaM+WpYmpKou5MUXF6vjiqZ\nqAF9EEOTwjH9Yl2PgMRqgQdl+uGnLYoAUOJL0K39kLHOl4mA8UujfhdD6EaWsuzp\npxluHdaQMYHBtPf9aqhzNVVSaBBuaOLFuCP76EfTqMhgbWV3ozUmCL+hJu84H8pq\nz2irgWT27g61YCv01a4B6O1ccAtRmKdSu2HEAidY0xVlNEfCrnqaVXXmmfo=\n-----END RSA PRIVATE KEY-----\n"
customCertChain = [siteCert, intermediateCert, rootCert]
parseCert text = Either.toException (decodeCert (Text.toUtf8 text))
defer comp =
result = Promise.new ()
_ = fork do Promise.write result (catchAll comp)
result
Optional.toException message = cases
Some x -> x
None -> raise (failure message 0)
-- client sends then receives
chainClient portPromise toSend =
use base.IO.net
defaultClient = (Tls.ClientConfig.default (HostName.HostName "intermediate") "")
tlsconfig = ClientConfig.certificates.set [parseCert rootCert] defaultClient
sock = Socket.client (HostName.HostName ("127" ++ ".0.0.1")) (Port.Port (Nat.toText (Promise.read portPromise)))
tls = Tls.newClient tlsconfig sock
tlsock = Tls.handshake tls
TlsSocket.send tlsock (Text.toUtf8 toSend)
-- res = fromUtf8 (TlsSocket.receive tlsock)
TlsSocket.terminate tlsock
-- res
-- server receives then sends
chainServer portPromise toSend =
use Text toUtf8
key = Optional.toException "No private key decoded" <| List.head (decodePrivateKey (toUtf8 intermediateKey)) -- siteKey
tlsconfig = Tls.ServerConfig.default [
-- parseCert siteKey,
parseCert intermediateCert,
parseCert rootCert ] key
sock = Socket.listen (server (Some (HostName ("127" ++ ".0.0.1"))) (Port "0"))
port = match sock with ListeningServerSocket sock -> Socket.port sock
_ = Promise.write portPromise port
sock' = Socket.accept sock
-- attach TLS to our TCP connection
tls = Tls.newServer tlsconfig sock'
tlsock = net.Tls.handshake tls
res = fromUtf8 (TlsSocket.receive tlsock)
-- TlsSocket.send tlsock (toUtf8 toSend)
TlsSocket.terminate tlsock
res
tlsChainTest = do
portPromise = Promise.new ()
clientSend = "12345"
serverSend = "56789"
-- Client
clientResult = defer do chainClient portPromise clientSend
-- Server
serverResult = defer do chainServer portPromise serverSend
-- Get the results
clientReceived = Either.toException <| Promise.read clientResult
serverReceived = Either.toException <| Promise.read serverResult
-- Check it
-- checkEqual "self signed chain client received" serverSend clientReceived
checkEqual "self signed chain server received" clientSend serverReceived

154
unison-src/builtin-tests/tls-tests.u
View File

@ -1,154 +0,0 @@
use base.Text toUtf8
tls.tests = do
check "decoding a cert should work" do isRight (decodeCert (toUtf8 selfSignedCert))
check "decoding a private key should work" do 1 == List.size (decodePrivateKey (toUtf8 selfSignedKey))
check "decoding an invalid private key should ignore" do 0 == List.size (decodePrivateKey (toUtf8 "not a private key"))
check "decoding an invalid cert should fail" do isLeft (decodeCert (toUtf8 "not a cert"))
!testConnectSelfSigned
!tlsChainTest
expectError' "self signed with the wrong hostname should fail" ["NameMismatch", "certificate verify failed"] testConnectSelfSignedWrongHost
expectError' "self signed with an unknown CA should fail" ["certificate has unknown CA", "certificate verify failed"] do
portPromise = Promise.new ()
toSend = "12345"
-- Server
serverResult = defer do serverThread portPromise toSend
-- Client
Either.toException !(testClient None "test.unison.cloud" portPromise)
expectError' "self signed wrong host" ["NameMismatch", "certificate verify failed"] testConnectSelfSignedWrongHost
-- -- TODO: Enable this once scheme output correctly escapes \r
-- check "connects to example.com over tls" tls.example.com
expectError' "wrong host example.com fails" ["NameMismatch", "certificate verify failed"] do
socket = Socket.client (HostName "example.com") (Port "443")
config = ClientConfig.default (HostName "examplez.com") ""
tls = base.IO.net.Tls.newClient config socket
_ = base.IO.net.Tls.handshake tls
()
-- expectError "trying to connect to example.com:443 without tls fails" "Connection reset" do
-- socket = Socket.client (HostName "example.com") (Port "443")
-- Socket.send socket (toUtf8 "GET /index.html HTTP/1.0\r\n\r\n")
-- Socket.receive socket
reencode.cert bytes =
match (decodeCert bytes) with
Right cert -> encodeCert cert
_ ->
Tests.fail "Unable to decode certificate" (fromUtf8' bytes)
bug "failed decoding"
fromUtf8' bytes = match catch '(fromUtf8 bytes) with
Right text -> text
Left _ -> "the bytes aren't utf8-encoded?"
reencode.priv bytes =
match (decodePrivateKey bytes) with
key +: [] -> encodePrivateKey key
_ ->
Tests.fail "Unable to decode private key" (fromUtf8' bytes)
bug "failed decoding"
tls.cert.codec = do
bytes = (toUtf8 selfSignedCert)
once = reencode.cert bytes
twice = reencode.cert once
checkEqual "encode a decoded certificate" once twice
-- lol the haskell impl for encodePrivateKey doesn't produce the correct type,
-- and also doesn't really encode it? what
tls.private.codec = do
bytes = (toUtf8 selfSignedKey)
once = reencode.priv bytes
twice = reencode.priv once
checkEqual "encode a decoded private key" once twice
tls.example.com = do
socket = Socket.client (HostName "example.com") (Port "443")
config = ClientConfig.default (HostName "example.com") ""
tls = base.IO.net.Tls.newClient config socket
conn = base.IO.net.Tls.handshake tls
TlsSocket.send conn (toUtf8 "GET /index.html HTTP/1.0\r\nHost: example.com\r\n\r\n")
response = TlsSocket.receive conn
TlsSocket.terminate conn
contains "HTTP/1.0 200 OK" (fromUtf8 response)
testConnectSelfSigned = do
portPromise = Promise.new ()
toSend = "12345"
-- Server
serverResult = defer do serverThread portPromise toSend
-- Client
received = clientThread "test.unison.cloud" portPromise
_ = Either.toException <| Promise.read serverResult
-- Check it
checkEqual "self signed should connect & receive what we sent" toSend received
matchesOne matchers text = match matchers with
[] -> false
one +: rest -> if Text.contains one text
then true
else matchesOne rest text
expectError' msg matchers fn = match catchAll fn with
Left (Failure _ message _) ->
if matchesOne matchers message
then
Tests.pass msg
else
Tests.fail msg ("Unexpected exception found " ++ message)
Right _ ->
Tests.fail msg "Expected exception, none found"
expectError msg text fn = expectError' msg [text] fn
testConnectSelfSignedWrongHost = do
-- Server
portPromise = Promise.new ()
toSend = "12345"
serverResult = defer do serverThread portPromise toSend
-- Client
_ = clientThread "some.other.hostname" portPromise
()
clientThread host portPromise =
cert = Either.toException (decodeCert (toUtf8 selfSignedCert))
Either.toException !(testClient (Some cert) host portPromise)
serverThread portPromise toSend =
cert = Either.toException (decodeCert (toUtf8 selfSignedCert))
key = Optional.toException "No private key decoded" <| List.head (decodePrivateKey (toUtf8 selfSignedKey))
tlsconfig = Tls.ServerConfig.default [cert] key
sock = Socket.listen (server (Some (HostName ("127" ++ ".0.0.1"))) (Port "0"))
port = match sock with ListeningServerSocket sock -> Socket.port sock
_ = Promise.write portPromise port
sock' = Socket.accept sock
-- attach TLS to our TCP connection
tls = Tls.newServer tlsconfig sock'
tlsock = net.Tls.handshake tls
TlsSocket.send tlsock (toUtf8 toSend)
TlsSocket.terminate tlsock
testClient : Optional SignedCert -> Text -> Promise Nat -> '{IO} Either Failure Text
testClient cert hostname portVar _ = catch do
use base.IO.net
-- create a client that will expect a cert from the given hostname (CN)
defaultClient = (Tls.ClientConfig.default (HostName.HostName hostname) "")
-- if we were passed a certificate to trust, it is the only certificate we trust
-- otherwise, we'll reject self-signed certificates
tlsconfig = match cert with
None -> defaultClient
Some (cert) -> defaultClient |> ClientConfig.certificates.set [cert]
-- create a tcp connection with the server
sock = Socket.client (HostName.HostName ("127" ++ ".0.0.1")) (Port.Port (Nat.toText (Promise.read portVar)))
-- attach the TLS client to the TCP socket
tls = Tls.newClient tlsconfig sock
-- verify that the server presents us with a certificate chain for
-- test.unison.cloud originating with a certificate we trust, and
-- that the server can use a compatible TLS version and cipher
tlsock = Tls.handshake tls
-- -- receive a message from the server
fromUtf8 (TlsSocket.receive tlsock)
-- generated with:
-- openssl req -newkey rsa:2048 -subj '/CN=test.unison.cloud/O=Unison/C=US' -nodes -keyout key.pem -x509 -days 3650 -out cert.pem
selfSignedKey = "-----BEGIN PRIVATE KEY-----\nMIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQDtV0Lqk9i5DKJG\ne5zwDFuxHxSxhOygCuq6Jl4xonsjl4hdvXxUUiuqxGGbv4x9HSvavpHwyriGiIRQ\noIjanWiNK9Jp6VDYWOvErnTG/+Rfm1vCoUKQvn8lDrD9knSPUoTz3Cz7JS8FE/rr\nFR3IRyXa0gpXmvIwX16SeCS/Lb/Le9o1HJh9DrkxVyoFq3zlX1OE0AVV0a014IDB\nNprqLITwiVzyDPQkP8rbJF9WPI5afzW8+3+v5UanIFknOOPaJl8pf3gmqI5g8fxk\n/SSMlPgnLd1Fi7h90gBygdpJw3do3/ZA1IOvmFQ+LXE1xtqU1Ay3f3At3DiJgTxP\n8mwBYdtdAgMBAAECggEBAMo85QRF3xIvtcchZeUWYrtWpKdvgMIPC1x7fSAGN69o\nXAakg+DF8/ebRyET435o8QmAAZOQ6hOZGEYrxPGj14cTpEQjT4RKoPwDO/al7c+Z\n7mK2TqZP7L+C+UXZGgFWa3vwTVPjp2FIWTMf1zTli1geSjnECkM1wLxGK+nL7fZQ\nesHXPkJJG5AqzA84bJ/fY5OQ/dfcCxnHEv5XpHPq6VFgXg7jtcNbr1R9EBiQfreN\nU7Hd38R77jYjL1fT71HwEUQ0cwavfxTu0jZFXJxEC7CC1J65QXUguZXLf9vwgSB0\nm0gZgeJlQ905bDJrxUcqCFxdROy/SndP6qFnJSCsfwECgYEA+2cld/WCieUGstJd\njsIrJ6f/e+uuOSTnGTtnsBX6KoiHdcg3sVVVK18xI9El9V+YX9SjN37XeGFe/Wzu\ngE3M4A3Jqz7cgdNj/PaKjqQwJWNbcJnL5ku6eQvcAIpc5gAZxXVCPIbY1ZpeYcsh\nMwr3cOEpQu8UVFBbn/OeJ1r07dECgYEA8a5J3Ls5PSxXq8NDrkAxt3vUJIWLGQQJ\nbV2aGDI2XP2N+vh2WML9rlFeyyBOeRxK9TsErVOaEeOcQZV97//fzIGxCU+SXyiC\nnVMXT2U1mzOu5qPfzLO5Ga4sunxqKDman6NM2IPw2NPA7zMWNQMEIHAerwYZzjm5\nB5tFcMA8e80CgYBgF8rwkTz2LD5lN5dfK8SHAeXbnfgYC4zxzg0R9zSJ8WmlkYQI\nGk/VpisIP7c8lO+PIZ3JZohBkSZXw71d+V7n/R0qgXqTfRNo62uGnidxAws+fOq8\n+hEql2feJQThPQScvvc0X26eJsUQqC3mbripwsacuPmSSKzc9Kds741TIQKBgQCd\nXnG2CytATAliTKlbY218HmOKzHJAfcJttk9KhhekAW5cB0F4lq98vHtPJOA0OFoO\nyLlI63EdSOpMQj1Y83IUxjYy699Rmx1BuAMrral0P/kZMYfe0QAsWp/BZpXxT2EB\npeG58l/3sBqnJsrFBgu/24H/UaeoAyoaa96Rhntb2QKBgQCSEkcUnzTvoUyMFN14\n8NttxOUZiSsCmgoXk6Rk2QKyCPsJocGS4BffGt3kOMcotz/0YsvM1TBBLB7vIaAy\nE1eWLBxK4yYeS8dKXwiCZn170yaJyjoBwZC1RgqQiKa5Y22Di7KjJoMa4Da8Tk4z\nFbE5dBApbLhvNTyQ7BHZxlfmdg==\n-----END PRIVATE KEY-----"
selfSignedCert = "-----BEGIN CERTIFICATE-----\nMIIDVTCCAj2gAwIBAgIUdMNT5sYMfDJYH48Rh8LrlN+5wwgwDQYJKoZIhvcNAQEL\nBQAwOjEaMBgGA1UEAwwRdGVzdC51bmlzb24uY2xvdWQxDzANBgNVBAoMBlVuaXNv\nbjELMAkGA1UEBhMCVVMwHhcNMjIwMTI0MjAxNzQ2WhcNMzIwMTIyMjAxNzQ2WjA6\nMRowGAYDVQQDDBF0ZXN0LnVuaXNvbi5jbG91ZDEPMA0GA1UECgwGVW5pc29uMQsw\nCQYDVQQGEwJVUzCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAO1XQuqT\n2LkMokZ7nPAMW7EfFLGE7KAK6romXjGieyOXiF29fFRSK6rEYZu/jH0dK9q+kfDK\nuIaIhFCgiNqdaI0r0mnpUNhY68SudMb/5F+bW8KhQpC+fyUOsP2SdI9ShPPcLPsl\nLwUT+usVHchHJdrSClea8jBfXpJ4JL8tv8t72jUcmH0OuTFXKgWrfOVfU4TQBVXR\nrTXggME2muoshPCJXPIM9CQ/ytskX1Y8jlp/Nbz7f6/lRqcgWSc449omXyl/eCao\njmDx/GT9JIyU+Cct3UWLuH3SAHKB2knDd2jf9kDUg6+YVD4tcTXG2pTUDLd/cC3c\nOImBPE/ybAFh210CAwEAAaNTMFEwHQYDVR0OBBYEFIfwxpuqtqxfCpaJGW32jH2J\nNbnYMB8GA1UdIwQYMBaAFIfwxpuqtqxfCpaJGW32jH2JNbnYMA8GA1UdEwEB/wQF\nMAMBAf8wDQYJKoZIhvcNAQELBQADggEBAKh7EDo5XjSd6J190WGH3V8v49J0Sh8M\nP7APe1eL8eTkW1Vh7/QCOhRpkSnyCz2OxJjjeFVAsCO3aLxlRM6wQZQKXu45iM2U\niPmv7ECS5xUn7LqRZd/JG1P6jvRPtBC1+oqA+NNDe27wzQp3rWyDG3pWZga8jJfW\nq+2xQ+s6GfzszxYZ/8MLn4zaUSymnOA+70yQ8czXkSO7MT2jJ7QDX8jxuJPZZARW\nuXeAYPRqD+b4MjdBATEtxgPTDWEi8gtfHFGUgInFhD4hOu+D3NLiE6lfR5brUqpQ\nZ4v8prCI8OjGSUx1dIJhqQHB5O0vdaxO0hkVdfqDVE93UrGBPwBRDlo=\n-----END CERTIFICATE-----"