From 91cb40a3094d43e26c86c40d5cd4757650fde406 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 14:32:26 -0800 Subject: [PATCH 1/6] Define enum for all foreign calls --- unison-runtime/src/Unison/Runtime/Builtin.hs | 249 +++++++++++++++++ .../src/Unison/Runtime/Foreign/Function.hs | 250 ++++++++++++++++++ 2 files changed, 499 insertions(+) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6c292f4a78..9ee5f04904 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -1844,6 +1844,255 @@ type FDecl v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) +foreignFuncTracking :: ForeignFunc' -> Sandbox +foreignFuncTracking = \case + IO_UDP_clientSocket_impl_v1 -> Tracked + IO_UDP_UDPSocket_recv_impl_v1 -> Tracked + IO_UDP_UDPSocket_send_impl_v1 -> Tracked + IO_UDP_UDPSocket_close_impl_v1 -> Tracked + IO_UDP_ListenSocket_close_impl_v1 -> Tracked + IO_UDP_UDPSocket_toText_impl_v1 -> Tracked + IO_UDP_serverSocket_impl_v1 -> Tracked + IO_UDP_ListenSocket_toText_impl_v1 -> Tracked + IO_UDP_ListenSocket_recvFrom_impl_v1 -> Tracked + IO_UDP_ClientSockAddr_toText_v1 -> Tracked + IO_UDP_ListenSocket_sendTo_impl_v1 -> Tracked + IO_openFile_impl_v3 -> Tracked + IO_closeFile_impl_v3 -> Tracked + IO_isFileEOF_impl_v3 -> Tracked + IO_isFileOpen_impl_v3 -> Tracked + IO_getEcho_impl_v1 -> Tracked + IO_ready_impl_v1 -> Tracked + IO_getChar_impl_v1 -> Tracked + IO_isSeekable_impl_v3 -> Tracked + IO_seekHandle_impl_v3 -> Tracked + IO_handlePosition_impl_v3 -> Tracked + IO_getBuffering_impl_v3 -> Tracked + IO_setBuffering_impl_v3 -> Tracked + IO_setEcho_impl_v1 -> Tracked + IO_getLine_impl_v1 -> Tracked + IO_getBytes_impl_v3 -> Tracked + IO_getSomeBytes_impl_v1 -> Tracked + IO_putBytes_impl_v3 -> Tracked + IO_systemTime_impl_v3 -> Tracked + IO_systemTimeMicroseconds_v1 -> Tracked + Clock_internals_monotonic_v1 -> Tracked + Clock_internals_realtime_v1 -> Tracked + Clock_internals_processCPUTime_v1 -> Tracked + Clock_internals_threadCPUTime_v1 -> Tracked + Clock_internals_sec_v1 -> Tracked + Clock_internals_nsec_v1 -> Tracked + Clock_internals_systemTimeZone_v1 -> Tracked + IO_getTempDirectory_impl_v3 -> Tracked + IO_createTempDirectory_impl_v3 -> Tracked + IO_getCurrentDirectory_impl_v3 -> Tracked + IO_setCurrentDirectory_impl_v3 -> Tracked + IO_fileExists_impl_v3 -> Tracked + IO_getEnv_impl_v1 -> Tracked + IO_getArgs_impl_v1 -> Tracked + IO_isDirectory_impl_v3 -> Tracked + IO_createDirectory_impl_v3 -> Tracked + IO_removeDirectory_impl_v3 -> Tracked + IO_renameDirectory_impl_v3 -> Tracked + IO_directoryContents_impl_v3 -> Tracked + IO_removeFile_impl_v3 -> Tracked + IO_renameFile_impl_v3 -> Tracked + IO_getFileTimestamp_impl_v3 -> Tracked + IO_getFileSize_impl_v3 -> Tracked + IO_serverSocket_impl_v3 -> Tracked + Socket_toText -> Tracked + Handle_toText -> Tracked + ThreadId_toText -> Tracked + IO_socketPort_impl_v3 -> Tracked + IO_listen_impl_v3 -> Tracked + IO_clientSocket_impl_v3 -> Tracked + IO_closeSocket_impl_v3 -> Tracked + IO_socketAccept_impl_v3 -> Tracked + IO_socketSend_impl_v3 -> Tracked + IO_socketReceive_impl_v3 -> Tracked + IO_kill_impl_v3 -> Tracked + IO_delay_impl_v3 -> Tracked + IO_stdHandle -> Tracked + IO_process_call -> Tracked + IO_process_start -> Tracked + IO_process_kill -> Tracked + IO_process_wait -> Tracked + IO_process_exitCode -> Tracked + MVar_new -> Tracked + MVar_newEmpty_v2 -> Tracked + MVar_take_impl_v3 -> Tracked + MVar_tryTake -> Tracked + MVar_put_impl_v3 -> Tracked + MVar_tryPut_impl_v3 -> Tracked + MVar_swap_impl_v3 -> Tracked + MVar_isEmpty -> Tracked + MVar_read_impl_v3 -> Tracked + MVar_tryRead_impl_v3 -> Tracked + Char_toText -> Untracked + Text_repeat -> Untracked + Text_reverse -> Untracked + Text_toUppercase -> Untracked + Text_toLowercase -> Untracked + Text_toUtf8 -> Untracked + Text_fromUtf8_impl_v3 -> Untracked + Tls_ClientConfig_default -> Tracked + Tls_ServerConfig_default -> Tracked + Tls_ClientConfig_certificates_set -> Tracked + Tls_ServerConfig_certificates_set -> Tracked + TVar_new -> Tracked + TVar_read -> Tracked + TVar_write -> Tracked + TVar_newIO -> Tracked + TVar_readIO -> Tracked + TVar_swap -> Tracked + STM_retry -> Tracked + Promise_new -> Tracked + Promise_read -> Tracked + Promise_tryRead -> Tracked + Promise_write -> Tracked + Tls_newClient_impl_v3 -> Tracked + Tls_newServer_impl_v3 -> Tracked + Tls_handshake_impl_v3 -> Tracked + Tls_send_impl_v3 -> Tracked + Tls_decodeCert_impl_v3 -> Tracked + Tls_encodeCert -> Tracked + Tls_decodePrivateKey -> Tracked + Tls_encodePrivateKey -> Tracked + Tls_receive_impl_v3 -> Tracked + Tls_terminate_impl_v3 -> Tracked + Code_validateLinks -> Untracked + Code_dependencies -> Untracked + Code_serialize -> Untracked + Code_deserialize -> Untracked + Code_display -> Untracked + Value_dependencies -> Untracked + Value_serialize -> Untracked + Value_deserialize -> Untracked + Crypto_HashAlgorithm_Sha3_512 -> Untracked + Crypto_HashAlgorithm_Sha3_256 -> Untracked + Crypto_HashAlgorithm_Sha2_512 -> Untracked + Crypto_HashAlgorithm_Sha2_256 -> Untracked + Crypto_HashAlgorithm_Sha1 -> Untracked + Crypto_HashAlgorithm_Blake2b_512 -> Untracked + Crypto_HashAlgorithm_Blake2b_256 -> Untracked + Crypto_HashAlgorithm_Blake2s_256 -> Untracked + Crypto_HashAlgorithm_Md5 -> Untracked + Crypto_hashBytes -> Untracked + Crypto_hmacBytes -> Untracked + Crypto_hash -> Untracked + Crypto_hmac -> Untracked + Crypto_Ed25519_sign_impl -> Untracked + Crypto_Ed25519_verify_impl -> Untracked + Crypto_Rsa_sign_impl -> Untracked + Crypto_Rsa_verify_impl -> Untracked + Universal_murmurHash -> Untracked + IO_randomBytes -> Tracked + Bytes_zlib_compress -> Untracked + Bytes_gzip_compress -> Untracked + Bytes_zlib_decompress -> Untracked + Bytes_gzip_decompress -> Untracked + Bytes_toBase16 -> Untracked + Bytes_toBase32 -> Untracked + Bytes_toBase64 -> Untracked + Bytes_toBase64UrlUnpadded -> Untracked + Bytes_fromBase16 -> Untracked + Bytes_fromBase32 -> Untracked + Bytes_fromBase64 -> Untracked + Bytes_fromBase64UrlUnpadded -> Untracked + Bytes_decodeNat64be -> Untracked + Bytes_decodeNat64le -> Untracked + Bytes_decodeNat32be -> Untracked + Bytes_decodeNat32le -> Untracked + Bytes_decodeNat16be -> Untracked + Bytes_decodeNat16le -> Untracked + Bytes_encodeNat64be -> Untracked + Bytes_encodeNat64le -> Untracked + Bytes_encodeNat32be -> Untracked + Bytes_encodeNat32le -> Untracked + Bytes_encodeNat16be -> Untracked + Bytes_encodeNat16le -> Untracked + MutableArray_copyTo_force -> Untracked + MutableByteArray_copyTo_force -> Untracked + ImmutableArray_copyTo_force -> Untracked + ImmutableArray_size -> Untracked + MutableArray_size -> Untracked + ImmutableByteArray_size -> Untracked + MutableByteArray_size -> Untracked + ImmutableByteArray_copyTo_force -> Untracked + MutableArray_read -> Untracked + MutableByteArray_read8 -> Untracked + MutableByteArray_read16be -> Untracked + MutableByteArray_read24be -> Untracked + MutableByteArray_read32be -> Untracked + MutableByteArray_read40be -> Untracked + MutableByteArray_read64be -> Untracked + MutableArray_write -> Untracked + MutableByteArray_write8 -> Untracked + MutableByteArray_write16be -> Untracked + MutableByteArray_write32be -> Untracked + MutableByteArray_write64be -> Untracked + ImmutableArray_read -> Untracked + ImmutableByteArray_read8 -> Untracked + ImmutableByteArray_read16be -> Untracked + ImmutableByteArray_read24be -> Untracked + ImmutableByteArray_read32be -> Untracked + ImmutableByteArray_read40be -> Untracked + ImmutableByteArray_read64be -> Untracked + MutableByteArray_freeze_force -> Untracked + MutableArray_freeze_force -> Untracked + MutableByteArray_freeze -> Untracked + MutableArray_freeze -> Untracked + MutableByteArray_length -> Untracked + ImmutableByteArray_length -> Untracked + IO_array -> Tracked + IO_arrayOf -> Tracked + IO_bytearray -> Tracked + IO_bytearrayOf -> Tracked + Scope_array -> Untracked + Scope_arrayOf -> Untracked + Scope_bytearray -> Untracked + Scope_bytearrayOf -> Untracked + Text_patterns_literal -> Untracked + Text_patterns_digit -> Untracked + Text_patterns_letter -> Untracked + Text_patterns_space -> Untracked + Text_patterns_punctuation -> Untracked + Text_patterns_anyChar -> Untracked + Text_patterns_eof -> Untracked + Text_patterns_charRange -> Untracked + Text_patterns_notCharRange -> Untracked + Text_patterns_charIn -> Untracked + Text_patterns_notCharIn -> Untracked + Pattern_many -> Untracked + Pattern_many_corrected -> Untracked + Pattern_capture -> Untracked + Pattern_captureAs -> Untracked + Pattern_join -> Untracked + Pattern_or -> Untracked + Pattern_replicate -> Untracked + Pattern_run -> Untracked + Pattern_isMatch -> Untracked + Char_Class_any -> Untracked + Char_Class_not -> Untracked + Char_Class_and -> Untracked + Char_Class_or -> Untracked + Char_Class_range -> Untracked + Char_Class_anyOf -> Untracked + Char_Class_alphanumeric -> Untracked + Char_Class_upper -> Untracked + Char_Class_lower -> Untracked + Char_Class_whitespace -> Untracked + Char_Class_control -> Untracked + Char_Class_printable -> Untracked + Char_Class_mark -> Untracked + Char_Class_number -> Untracked + Char_Class_punctuation -> Untracked + Char_Class_symbol -> Untracked + Char_Class_separator -> Untracked + Char_Class_letter -> Untracked + Char_Class_is -> Untracked + Text_patterns_char -> Untracked + bomb :: Data.Text.Text -> a -> IO r bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 60808351e1..654ca70f32 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -8,6 +8,7 @@ module Unison.Runtime.Foreign.Function ( ForeignFunc (..), ForeignConvention (..), + ForeignFunc' (..), mkForeign, ) where @@ -50,6 +51,255 @@ import Unison.Util.Bytes (Bytes) import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text, pack, unpack) +-- | Enum representing every foreign call. +data ForeignFunc' + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + -- Foreign functions operating on stacks data ForeignFunc where FF :: From 1444456119ac18a4a726c7991e9d1c49fa9b8de5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 15:33:57 -0800 Subject: [PATCH 2/6] Implement a bunch of builtin impls --- unison-runtime/src/Unison/Runtime/Builtin.hs | 534 ++++---------- .../src/Unison/Runtime/Foreign/Function.hs | 249 ------- .../src/Unison/Runtime/Foreign/Impl.hs | 679 ++++++++++++++++++ unison-runtime/src/Unison/Runtime/MCode.hs | 256 +++++++ unison-runtime/src/Unison/Runtime/Machine.hs | 31 +- unison-runtime/unison-runtime.cabal | 1 + 6 files changed, 1088 insertions(+), 662 deletions(-) create mode 100644 unison-runtime/src/Unison/Runtime/Foreign/Impl.hs diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 9ee5f04904..2a015691d0 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -20,6 +20,7 @@ module Unison.Runtime.Builtin numberedTermLookup, Sandbox (..), baseSandboxInfo, + unitValue, ) where @@ -1837,6 +1838,9 @@ builtinLookup = type FDecl v = ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) +type FDecl' v = + ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc'))) + -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked -- means that the sandboxing check will by default consider them @@ -2114,17 +2118,22 @@ declareForeign sand name op func0 = do code = (name, (sand, uncurry Lambda (op w))) in (w + 1, code : codes, mapInsert w (name, func) funcs) -mkForeignIOF :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) - where - tryIOE :: IO a -> IO (Either Failure a) - tryIOE = fmap handleIOE . try - handleIOE :: Either IOException a -> Either Failure a - handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue - handleIOE (Right a) = Right a +declareForeign' :: + Sandbox -> + Data.Text.Text -> + ForeignOp -> + ForeignFunc' -> + FDecl' Symbol () +declareForeign' sand name op func0 = do + sanitize <- ask + modify $ \(w, codes, funcs) -> + let func + | sanitize, + Tracked <- sand = + error "TODO: fill in sandboxing error" + | otherwise = func0 + code = (name, (sand, uncurry Lambda (op w))) + in (w + 1, code : codes, mapInsert w (name, func) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -2132,471 +2141,196 @@ unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) natValue :: Word64 -> Val natValue w = NatVal w -mkForeignTls :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO r -> IO (Either TLS.TLSException r) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException r) -> Either (Failure) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right a)) = Right a - -mkForeignTlsE :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either Failure r)) -> - ForeignFunc -mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right (Left e))) = Left e - flatten (Right (Right (Right a))) = Right a - -declareUdpForeigns :: FDecl Symbol () +declareUdpForeigns :: FDecl' Symbol () declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF - . mkForeignIOF - $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> - let hostStr = Util.Text.toString host - portStr = Util.Text.toString port - in UDP.clientSocket hostStr portStr True - - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF - . mkForeignIOF - $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock - - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> - UDP.send sock (Bytes.toArray bytes) - - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket) -> UDP.close sock - - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 - . mkForeignIOF - $ \(sock :: ListenSocket) -> UDP.stop sock - - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) - . mkForeign - $ \(sock :: UDPSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF - . mkForeignIOF - $ \(ip :: Util.Text.Text, port :: Util.Text.Text) -> - let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP - maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber - in case (maybeIp, maybePort) of - (Nothing, _) -> fail "Invalid IP Address" - (_, Nothing) -> fail "Invalid Port Number" - (Just ip, Just pt) -> UDP.serverSocket (ip, pt) - - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) - . mkForeign - $ \(sock :: ListenSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup - . mkForeignIOF - $ fmap (first Bytes.fromArray) <$> UDP.recvFrom - - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) - . mkForeign - $ \(sock :: ClientSockAddr) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 - . mkForeignIOF - $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> - UDP.sendTo socket (Bytes.toArray bytes) addr - -declareForeigns :: FDecl Symbol () -declareForeigns = do - declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF $ - mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> - let fname = Util.Text.toString fnameText - mode = case n of - 0 -> ReadMode - 1 -> WriteMode - 2 -> AppendMode - _ -> ReadWriteMode - in openFile fname mode - - declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 $ mkForeignIOF hClose - declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool $ mkForeignIOF hIsEOF - declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool $ mkForeignIOF hIsOpen - declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool $ mkForeignIOF hGetEcho - declareForeign Tracked "IO.ready.impl.v1" argToEFBool $ mkForeignIOF hReady - declareForeign Tracked "IO.getChar.impl.v1" argToEFChar $ mkForeignIOF hGetChar - declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool $ mkForeignIOF hIsSeekable - - declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle - . mkForeignIOF - $ \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) - - declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \h -> fromInteger @Word64 <$> hTell h - - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering $ - mkForeignIOF hGetBuffering - - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering - . mkForeignIOF - $ uncurry hSetBuffering - - declareForeign Tracked "IO.setEcho.impl.v1" set'echo . mkForeignIOF $ uncurry hSetEcho - - declareForeign Tracked "IO.getLine.impl.v1" argToEF $ - mkForeignIOF $ - fmap Util.Text.fromText . Text.IO.hGetLine + declareForeign' Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGet h n + declareForeign' Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGetSome h n + declareForeign' Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign' Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + declareForeign' Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked "IO.systemTime.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> getPOSIXTime + declareForeign' Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR $ - mkForeign $ - \() -> fmap (1e6 *) getPOSIXTime + declareForeign' Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Monotonic + declareForeign' Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked "Clock.internals.realtime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Realtime + declareForeign' Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ProcessCPUTime + declareForeign' Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ThreadCPUTime + declareForeign' Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 - declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) +declareForeigns :: FDecl' Symbol () +declareForeigns = do + declareUdpForeigns + declareForeign' Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 - -- A TimeSpec that comes from getTime never has negative nanos, - -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) - - declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone $ - mkForeign - ( \secs -> do - TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) - pure (offset :: Int, summer, name) - ) + declareForeign' Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 + declareForeign' Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 + declareForeign' Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 + declareForeign' Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 + declareForeign' Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 + declareForeign' Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 + declareForeign' Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 - let chop = reverse . dropWhile isPathSeparator . reverse + declareForeign' Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> chop <$> getTemporaryDirectory + declareForeign' Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 - declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF $ - mkForeignIOF $ \prefix -> do - temp <- getTemporaryDirectory - chop <$> createTempDirectory temp prefix + declareForeign' Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF - . mkForeignIOF - $ \() -> getCurrentDirectory + declareForeign' Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 $ - mkForeignIOF setCurrentDirectory + declareForeign' Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 - declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool $ - mkForeignIOF doesPathExist + declareForeign' Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 - declareForeign Tracked "IO.getEnv.impl.v1" argToEF $ - mkForeignIOF getEnv + declareForeign' Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 + declareForeign' Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign' Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 + declareForeign' Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 - declareForeign Tracked "IO.getArgs.impl.v1" unitToEF $ - mkForeignIOF $ - \() -> fmap Util.Text.pack <$> SYS.getArgs + declareForeign' Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 - declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool $ - mkForeignIOF doesDirectoryExist + declareForeign' Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 - declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 $ - mkForeignIOF $ - createDirectoryIfMissing True + declareForeign' Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 - declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 $ - mkForeignIOF removeDirectoryRecursive + declareForeign' Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 - declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameDirectory + declareForeign' Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 - declareForeign Tracked "IO.directoryContents.impl.v3" argToEF $ - mkForeignIOF $ - (fmap Util.Text.pack <$>) . getDirectoryContents + declareForeign' Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 - declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 $ - mkForeignIOF removeFile + -- A TimeSpec that comes from getTime never has negative nanos, + -- so we can safely cast to Nat + declareForeign' Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 - declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameFile + declareForeign' Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 - declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat - . mkForeignIOF - $ fmap utcTimeToPOSIXSeconds . getModificationTime + declareForeign' Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 - declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \fp -> fromInteger @Word64 <$> getFileSize fp + declareForeign' Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 - declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF - . mkForeignIOF - $ \( mhst :: Maybe Util.Text.Text, - port - ) -> - fst <$> SYS.bindSock (hostPreference mhst) port + declareForeign' Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign Tracked "Socket.toText" (argNDirect 1) - . mkForeign - $ \(sock :: Socket) -> pure $ show sock + declareForeign' Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked "Handle.toText" (argNDirect 1) - . mkForeign - $ \(hand :: Handle) -> pure $ show hand + declareForeign' Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 - declareForeign Tracked "ThreadId.toText" (argNDirect 1) - . mkForeign - $ \(threadId :: ThreadId) -> pure $ show threadId + declareForeign' Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 - declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat - . mkForeignIOF - $ \(handle :: Socket) -> do - n <- SYS.socketPort handle - return (fromIntegral n :: Word64) + declareForeign' Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 - declareForeign Tracked "IO.listen.impl.v3" argToEF0 - . mkForeignIOF - $ \sk -> SYS.listenSock sk 2048 + declareForeign' Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 - declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF - . mkForeignIOF - $ fmap fst . uncurry SYS.connectSock + declareForeign' Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 - declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 $ - mkForeignIOF SYS.closeSock + declareForeign' Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 - declareForeign Tracked "IO.socketAccept.impl.v3" argToEF - . mkForeignIOF - $ fmap fst . SYS.accept + declareForeign' Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 - declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + declareForeign' Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 - declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF - . mkForeignIOF - $ \(hs, n) -> - maybe mempty Bytes.fromArray <$> SYS.recv hs n + declareForeign' Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 - declareForeign Tracked "IO.kill.impl.v3" argToEF0 $ mkForeignIOF killThread + declareForeign' Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 - let mx :: Word64 - mx = fromIntegral (maxBound :: Int) + declareForeign' Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 - customDelay :: Word64 -> IO () - customDelay n - | n < mx = threadDelay (fromIntegral n) - | otherwise = threadDelay maxBound >> customDelay (n - mx) + declareForeign' Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 - declareForeign Tracked "IO.delay.impl.v3" argToEFUnit $ - mkForeignIOF customDelay + declareForeign' Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 - declareForeign Tracked "IO.stdHandle" standard'handle - . mkForeign - $ \(n :: Int) -> case n of - 0 -> pure SYS.stdin - 1 -> pure SYS.stdout - 2 -> pure SYS.stderr - _ -> die "IO.stdHandle: invalid input." + declareForeign' Tracked "Socket.toText" (argNDirect 1) Socket_toText - let exitDecode ExitSuccess = 0 - exitDecode (ExitFailure n) = n + declareForeign' Tracked "Handle.toText" (argNDirect 1) Handle_toText - declareForeign Tracked "IO.process.call" (argNDirect 2) . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - withCreateProcess (proc exe args) $ \_ _ _ p -> - exitDecode <$> waitForProcess p + declareForeign' Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText - declareForeign Tracked "IO.process.start" start'process . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - runInteractiveProcess exe args Nothing Nothing + declareForeign' Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 - declareForeign Tracked "IO.process.kill" argToUnit . mkForeign $ - terminateProcess + declareForeign' Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 - declareForeign Tracked "IO.process.wait" (argNDirect 1) . mkForeign $ - \ph -> exitDecode <$> waitForProcess ph + declareForeign' Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 - declareForeign Tracked "IO.process.exitCode" argToMaybe . mkForeign $ - fmap (fmap exitDecode) . getProcessExitCode + declareForeign' Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 - declareForeign Tracked "MVar.new" (argNDirect 1) - . mkForeign - $ \(c :: Val) -> newMVar c + declareForeign' Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 - declareForeign Tracked "MVar.newEmpty.v2" unitDirect - . mkForeign - $ \() -> newEmptyMVar @Val + declareForeign' Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 - declareForeign Tracked "MVar.take.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> takeMVar mv + declareForeign' Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 - declareForeign Tracked "MVar.tryTake" argToMaybe - . mkForeign - $ \(mv :: MVar Val) -> tryTakeMVar mv + declareForeign' Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 - declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(mv :: MVar Val, x) -> putMVar mv x + declareForeign' Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 - declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool - . mkForeignIOF - $ \(mv :: MVar Val, x) -> tryPutMVar mv x + declareForeign' Tracked "IO.stdHandle" standard'handle IO_stdHandle - declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF - . mkForeignIOF - $ \(mv :: MVar Val, x) -> swapMVar mv x + declareForeign' Tracked "IO.process.call" (argNDirect 2) IO_process_call - declareForeign Tracked "MVar.isEmpty" (argNDirect 1) - . mkForeign - $ \(mv :: MVar Val) -> isEmptyMVar mv - - declareForeign Tracked "MVar.read.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> readMVar mv - - declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM - . mkForeignIOF - $ \(mv :: MVar Val) -> tryReadMVar mv - - declareForeign Untracked "Char.toText" (argNDirect 1) . mkForeign $ - \(ch :: Char) -> pure (Util.Text.singleton ch) + declareForeign' Tracked "IO.process.start" start'process IO_process_start - declareForeign Untracked "Text.repeat" (argNDirect 2) . mkForeign $ - \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + declareForeign' Tracked "IO.process.kill" argToUnit IO_process_kill - declareForeign Untracked "Text.reverse" (argNDirect 1) . mkForeign $ - pure . Util.Text.reverse + declareForeign' Tracked "IO.process.wait" (argNDirect 1) IO_process_wait - declareForeign Untracked "Text.toUppercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUppercase + declareForeign' Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode + declareForeign' Tracked "MVar.new" (argNDirect 1) MVar_new - declareForeign Untracked "Text.toLowercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toLowercase + declareForeign' Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 - declareForeign Untracked "Text.toUtf8" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUtf8 - - declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF . mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 - - declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) . mkForeign $ - \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> - fmap - ( \store -> - (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) - { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.clientShared = def {TLS.sharedCAStore = store} - } - ) - X.getSystemCertificateStore + declareForeign' Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 - declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) $ - mkForeign $ - \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> - pure $ - (def :: TLS.ServerParams) - { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} - } + declareForeign' Tracked "MVar.tryTake" argToMaybe MVar_tryTake - let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams - updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + declareForeign' Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 - let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams - updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + declareForeign' Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign Tracked "TVar.new" (argNDirect 1) . mkForeign $ - \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + declareForeign' Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 - declareForeign Tracked "TVar.read" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + declareForeign' Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty - declareForeign Tracked "TVar.write" arg2To0 . mkForeign $ - \(v :: STM.TVar Val, c :: Val) -> - unsafeSTMToIO $ STM.writeTVar v c + declareForeign' Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 - declareForeign Tracked "TVar.newIO" (argNDirect 1) . mkForeign $ - \(c :: Val) -> STM.newTVarIO c + declareForeign' Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 - declareForeign Tracked "TVar.readIO" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> STM.readTVarIO v + declareForeign' Untracked "Char.toText" (argNDirect 1) Char_toText + declareForeign' Untracked "Text.repeat" (argNDirect 2) Text_repeat + declareForeign' Untracked "Text.reverse" (argNDirect 1) Text_reverse + declareForeign' Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase + declareForeign' Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase + declareForeign' Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 + declareForeign' Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 + declareForeign' Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default + declareForeign' Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default + declareForeign' Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set - declareForeign Tracked "TVar.swap" (argNDirect 2) . mkForeign $ - \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + declareForeign' Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign Tracked "STM.retry" unitDirect . mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Val + declareForeign' Tracked "TVar.new" (argNDirect 1) TVar_new - declareForeign Tracked "Promise.new" unitDirect . mkForeign $ - \() -> newPromise @Val + declareForeign' Tracked "TVar.read" (argNDirect 1) TVar_read + declareForeign' Tracked "TVar.write" arg2To0 TVar_write + declareForeign' Tracked "TVar.newIO" (argNDirect 1) TVar_newIO + declareForeign' Tracked "TVar.readIO" (argNDirect 1) TVar_readIO + declareForeign' Tracked "TVar.swap" (argNDirect 2) TVar_swap + declareForeign' Tracked "STM.retry" unitDirect STM_retry + declareForeign' Tracked "Promise.new" unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" (argNDirect 1) . mkForeign $ - \(p :: Promise Val) -> readPromise p + declareForeign' Tracked "Promise.read" (argNDirect 1) Promise_read + declareForeign' Tracked "Promise.tryRead" argToMaybe Promise_tryRead - declareForeign Tracked "Promise.tryRead" argToMaybe . mkForeign $ - \(p :: Promise Val) -> tryReadPromise p - - declareForeign Tracked "Promise.write" (argNDirect 2) . mkForeign $ - \(p :: Promise Val, a :: Val) -> writePromise p a - - declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF . mkForeignTls $ - \( config :: TLS.ClientParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ + declareForeign' Tracked "Promise.write" (argNDirect 2) Promise_write + declareForeign' Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 + declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ \( config :: TLS.ServerParams, socket :: SYS.Socket ) -> TLS.contextNew socket config @@ -3325,10 +3059,6 @@ checkBoundsPrim name isz off esz act bsz = fromIntegral isz w = off + esz -hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference -hostPreference Nothing = SYS.HostAny -hostPreference (Just host) = SYS.Host $ Util.Text.unpack host - signEd25519Wrapper :: (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes signEd25519Wrapper (secret0, public0, msg0) = case validated of diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 654ca70f32..e16b548d69 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -51,255 +51,6 @@ import Unison.Util.Bytes (Bytes) import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text, pack, unpack) --- | Enum representing every foreign call. -data ForeignFunc' - = IO_UDP_clientSocket_impl_v1 - | IO_UDP_UDPSocket_recv_impl_v1 - | IO_UDP_UDPSocket_send_impl_v1 - | IO_UDP_UDPSocket_close_impl_v1 - | IO_UDP_ListenSocket_close_impl_v1 - | IO_UDP_UDPSocket_toText_impl_v1 - | IO_UDP_serverSocket_impl_v1 - | IO_UDP_ListenSocket_toText_impl_v1 - | IO_UDP_ListenSocket_recvFrom_impl_v1 - | IO_UDP_ClientSockAddr_toText_v1 - | IO_UDP_ListenSocket_sendTo_impl_v1 - | IO_openFile_impl_v3 - | IO_closeFile_impl_v3 - | IO_isFileEOF_impl_v3 - | IO_isFileOpen_impl_v3 - | IO_getEcho_impl_v1 - | IO_ready_impl_v1 - | IO_getChar_impl_v1 - | IO_isSeekable_impl_v3 - | IO_seekHandle_impl_v3 - | IO_handlePosition_impl_v3 - | IO_getBuffering_impl_v3 - | IO_setBuffering_impl_v3 - | IO_setEcho_impl_v1 - | IO_getLine_impl_v1 - | IO_getBytes_impl_v3 - | IO_getSomeBytes_impl_v1 - | IO_putBytes_impl_v3 - | IO_systemTime_impl_v3 - | IO_systemTimeMicroseconds_v1 - | Clock_internals_monotonic_v1 - | Clock_internals_realtime_v1 - | Clock_internals_processCPUTime_v1 - | Clock_internals_threadCPUTime_v1 - | Clock_internals_sec_v1 - | Clock_internals_nsec_v1 - | Clock_internals_systemTimeZone_v1 - | IO_getTempDirectory_impl_v3 - | IO_createTempDirectory_impl_v3 - | IO_getCurrentDirectory_impl_v3 - | IO_setCurrentDirectory_impl_v3 - | IO_fileExists_impl_v3 - | IO_getEnv_impl_v1 - | IO_getArgs_impl_v1 - | IO_isDirectory_impl_v3 - | IO_createDirectory_impl_v3 - | IO_removeDirectory_impl_v3 - | IO_renameDirectory_impl_v3 - | IO_directoryContents_impl_v3 - | IO_removeFile_impl_v3 - | IO_renameFile_impl_v3 - | IO_getFileTimestamp_impl_v3 - | IO_getFileSize_impl_v3 - | IO_serverSocket_impl_v3 - | Socket_toText - | Handle_toText - | ThreadId_toText - | IO_socketPort_impl_v3 - | IO_listen_impl_v3 - | IO_clientSocket_impl_v3 - | IO_closeSocket_impl_v3 - | IO_socketAccept_impl_v3 - | IO_socketSend_impl_v3 - | IO_socketReceive_impl_v3 - | IO_kill_impl_v3 - | IO_delay_impl_v3 - | IO_stdHandle - | IO_process_call - | IO_process_start - | IO_process_kill - | IO_process_wait - | IO_process_exitCode - | MVar_new - | MVar_newEmpty_v2 - | MVar_take_impl_v3 - | MVar_tryTake - | MVar_put_impl_v3 - | MVar_tryPut_impl_v3 - | MVar_swap_impl_v3 - | MVar_isEmpty - | MVar_read_impl_v3 - | MVar_tryRead_impl_v3 - | Char_toText - | Text_repeat - | Text_reverse - | Text_toUppercase - | Text_toLowercase - | Text_toUtf8 - | Text_fromUtf8_impl_v3 - | Tls_ClientConfig_default - | Tls_ServerConfig_default - | Tls_ClientConfig_certificates_set - | Tls_ServerConfig_certificates_set - | TVar_new - | TVar_read - | TVar_write - | TVar_newIO - | TVar_readIO - | TVar_swap - | STM_retry - | Promise_new - | Promise_read - | Promise_tryRead - | Promise_write - | Tls_newClient_impl_v3 - | Tls_newServer_impl_v3 - | Tls_handshake_impl_v3 - | Tls_send_impl_v3 - | Tls_decodeCert_impl_v3 - | Tls_encodeCert - | Tls_decodePrivateKey - | Tls_encodePrivateKey - | Tls_receive_impl_v3 - | Tls_terminate_impl_v3 - | Code_validateLinks - | Code_dependencies - | Code_serialize - | Code_deserialize - | Code_display - | Value_dependencies - | Value_serialize - | Value_deserialize - | Crypto_HashAlgorithm_Sha3_512 - | Crypto_HashAlgorithm_Sha3_256 - | Crypto_HashAlgorithm_Sha2_512 - | Crypto_HashAlgorithm_Sha2_256 - | Crypto_HashAlgorithm_Sha1 - | Crypto_HashAlgorithm_Blake2b_512 - | Crypto_HashAlgorithm_Blake2b_256 - | Crypto_HashAlgorithm_Blake2s_256 - | Crypto_HashAlgorithm_Md5 - | Crypto_hashBytes - | Crypto_hmacBytes - | Crypto_hash - | Crypto_hmac - | Crypto_Ed25519_sign_impl - | Crypto_Ed25519_verify_impl - | Crypto_Rsa_sign_impl - | Crypto_Rsa_verify_impl - | Universal_murmurHash - | IO_randomBytes - | Bytes_zlib_compress - | Bytes_gzip_compress - | Bytes_zlib_decompress - | Bytes_gzip_decompress - | Bytes_toBase16 - | Bytes_toBase32 - | Bytes_toBase64 - | Bytes_toBase64UrlUnpadded - | Bytes_fromBase16 - | Bytes_fromBase32 - | Bytes_fromBase64 - | Bytes_fromBase64UrlUnpadded - | Bytes_decodeNat64be - | Bytes_decodeNat64le - | Bytes_decodeNat32be - | Bytes_decodeNat32le - | Bytes_decodeNat16be - | Bytes_decodeNat16le - | Bytes_encodeNat64be - | Bytes_encodeNat64le - | Bytes_encodeNat32be - | Bytes_encodeNat32le - | Bytes_encodeNat16be - | Bytes_encodeNat16le - | MutableArray_copyTo_force - | MutableByteArray_copyTo_force - | ImmutableArray_copyTo_force - | ImmutableArray_size - | MutableArray_size - | ImmutableByteArray_size - | MutableByteArray_size - | ImmutableByteArray_copyTo_force - | MutableArray_read - | MutableByteArray_read8 - | MutableByteArray_read16be - | MutableByteArray_read24be - | MutableByteArray_read32be - | MutableByteArray_read40be - | MutableByteArray_read64be - | MutableArray_write - | MutableByteArray_write8 - | MutableByteArray_write16be - | MutableByteArray_write32be - | MutableByteArray_write64be - | ImmutableArray_read - | ImmutableByteArray_read8 - | ImmutableByteArray_read16be - | ImmutableByteArray_read24be - | ImmutableByteArray_read32be - | ImmutableByteArray_read40be - | ImmutableByteArray_read64be - | MutableByteArray_freeze_force - | MutableArray_freeze_force - | MutableByteArray_freeze - | MutableArray_freeze - | MutableByteArray_length - | ImmutableByteArray_length - | IO_array - | IO_arrayOf - | IO_bytearray - | IO_bytearrayOf - | Scope_array - | Scope_arrayOf - | Scope_bytearray - | Scope_bytearrayOf - | Text_patterns_literal - | Text_patterns_digit - | Text_patterns_letter - | Text_patterns_space - | Text_patterns_punctuation - | Text_patterns_anyChar - | Text_patterns_eof - | Text_patterns_charRange - | Text_patterns_notCharRange - | Text_patterns_charIn - | Text_patterns_notCharIn - | Pattern_many - | Pattern_many_corrected - | Pattern_capture - | Pattern_captureAs - | Pattern_join - | Pattern_or - | Pattern_replicate - | Pattern_run - | Pattern_isMatch - | Char_Class_any - | Char_Class_not - | Char_Class_and - | Char_Class_or - | Char_Class_range - | Char_Class_anyOf - | Char_Class_alphanumeric - | Char_Class_upper - | Char_Class_lower - | Char_Class_whitespace - | Char_Class_control - | Char_Class_printable - | Char_Class_mark - | Char_Class_number - | Char_Class_punctuation - | Char_Class_symbol - | Char_Class_separator - | Char_Class_letter - | Char_Class_is - | Text_patterns_char - -- Foreign functions operating on stacks data ForeignFunc where FF :: diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs new file mode 100644 index 0000000000..d7b58b54eb --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -0,0 +1,679 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Unison.Runtime.Foreign.Impl (foreignCall) where + +import Control.Concurrent (ThreadId) +import Control.Concurrent as SYS + ( killThread, + threadDelay, + ) +import Control.Concurrent.MVar as SYS +import Control.Concurrent.STM qualified as STM +import Control.DeepSeq (NFData) +import Control.Exception +import Control.Exception (evaluate) +import Control.Exception.Safe qualified as Exception +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Primitive qualified as PA +import Control.Monad.Reader (ReaderT (..), ask, runReaderT) +import Control.Monad.State.Strict (State, execState, modify) +import Crypto.Error (CryptoError (..), CryptoFailable (..)) +import Crypto.Hash qualified as Hash +import Crypto.MAC.HMAC qualified as HMAC +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Crypto.PubKey.RSA.PKCS15 qualified as RSA +import Crypto.Random (getRandomBytes) +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.ByteArray qualified as BA +import Data.ByteString (hGet, hGetSome, hPut) +import Data.ByteString.Lazy qualified as L +import Data.Default (def) +import Data.Digest.Murmur64 (asWord64, hash64) +import Data.IP (IP) +import Data.Map qualified as Map +import Data.PEM (PEM, pemContent, pemParseLBS) +import Data.Set (insert) +import Data.Set qualified as Set +import Data.Text qualified +import Data.Text.IO qualified as Text.IO +import Data.Time.Clock.POSIX as SYS + ( getPOSIXTime, + posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.LocalTime (TimeZone (..), getTimeZone) +import Data.X509 qualified as X +import Data.X509.CertificateStore qualified as X +import Data.X509.Memory qualified as X +import GHC.Conc qualified as STM +import GHC.IO (IO (IO)) +import Network.Simple.TCP as SYS + ( HostPreference (..), + bindSock, + closeSock, + connectSock, + listenSock, + recv, + send, + ) +import Network.Socket as SYS + ( PortNumber, + Socket, + accept, + socketPort, + ) +import Network.TLS as TLS +import Network.TLS.Extra.Cipher as Cipher +import Network.UDP as UDP + ( ClientSockAddr, + ListenSocket, + UDPSocket (..), + clientSocket, + close, + recv, + recvFrom, + send, + sendTo, + serverSocket, + stop, + ) +import System.Clock (Clock (..), getTime, nsec, sec) +import System.Directory as SYS + ( createDirectoryIfMissing, + doesDirectoryExist, + doesPathExist, + getCurrentDirectory, + getDirectoryContents, + getFileSize, + getModificationTime, + getTemporaryDirectory, + removeDirectoryRecursive, + removeFile, + renameDirectory, + renameFile, + setCurrentDirectory, + ) +import System.Environment as SYS + ( getArgs, + getEnv, + ) +import System.Exit as SYS (ExitCode (..)) +import System.FilePath (isPathSeparator) +import System.IO (Handle) +import System.IO as SYS + ( IOMode (..), + hClose, + hGetBuffering, + hGetChar, + hGetEcho, + hIsEOF, + hIsOpen, + hIsSeekable, + hReady, + hSeek, + hSetBuffering, + hSetEcho, + hTell, + openFile, + stderr, + stdin, + stdout, + ) +import System.IO.Temp (createTempDirectory) +import System.Process as SYS + ( getProcessExitCode, + proc, + runInteractiveProcess, + terminateProcess, + waitForProcess, + withCreateProcess, + ) +import System.X509 qualified as X +import Unison.ABT.Normalized hiding (TTm) +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Referent (Referent, pattern Ref) +import Unison.Runtime.ANF as ANF +import Unison.Runtime.ANF.Rehash (checkGroupHashes) +import Unison.Runtime.ANF.Serialize as ANF +import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin +import Unison.Runtime.Builtin.Types +import Unison.Runtime.Crypto.Rsa as Rsa +import Unison.Runtime.Exception (die) +import Unison.Runtime.Foreign +import Unison.Runtime.Foreign + ( Foreign (Wrap), + HashAlgorithm (..), + pattern Failure, + ) +import Unison.Runtime.Foreign qualified as F +import Unison.Runtime.Foreign.Function hiding (mkForeign) +import Unison.Runtime.MCode +import Unison.Runtime.Stack +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) +import Unison.Runtime.Stack qualified as Closure +import Unison.Symbol +import Unison.Type qualified as Ty +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.EnumContainers as EC +import Unison.Util.RefPromise + ( Promise, + newPromise, + readPromise, + tryReadPromise, + writePromise, + ) +import Unison.Util.Text (Text) +import Unison.Util.Text qualified as Util.Text +import Unison.Util.Text.Pattern qualified as TPat +import Unison.Var +import UnliftIO qualified + +foreignCall :: ForeignFunc' -> Args -> Stack -> IO Stack +foreignCall = \case + IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> + let hostStr = Util.Text.toString host + portStr = Util.Text.toString port + in UDP.clientSocket hostStr portStr True + IO_UDP_UDPSocket_recv_impl_v1 -> mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock + IO_UDP_UDPSocket_send_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> + UDP.send sock (Bytes.toArray bytes) + IO_UDP_UDPSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket) -> UDP.close sock + IO_UDP_ListenSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: ListenSocket) -> UDP.stop sock + IO_UDP_UDPSocket_toText_impl_v1 -> mkForeign $ + \(sock :: UDPSocket) -> pure $ show sock + IO_UDP_serverSocket_impl_v1 -> mkForeignIOF $ + \(ip :: Util.Text.Text, port :: Util.Text.Text) -> + let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP + maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber + in case (maybeIp, maybePort) of + (Nothing, _) -> fail "Invalid IP Address" + (_, Nothing) -> fail "Invalid Port Number" + (Just ip, Just pt) -> UDP.serverSocket (ip, pt) + IO_UDP_ListenSocket_toText_impl_v1 -> mkForeign $ + \(sock :: ListenSocket) -> pure $ show sock + IO_UDP_ListenSocket_recvFrom_impl_v1 -> + mkForeignIOF $ + fmap (first Bytes.fromArray) <$> UDP.recvFrom + IO_UDP_ClientSockAddr_toText_v1 -> mkForeign $ + \(sock :: ClientSockAddr) -> pure $ show sock + IO_UDP_ListenSocket_sendTo_impl_v1 -> mkForeignIOF $ + \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> + UDP.sendTo socket (Bytes.toArray bytes) addr + IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> + let fname = Util.Text.toString fnameText + mode = case n of + 0 -> ReadMode + 1 -> WriteMode + 2 -> AppendMode + _ -> ReadWriteMode + in openFile fname mode + IO_closeFile_impl_v3 -> mkForeignIOF hClose + IO_isFileEOF_impl_v3 -> mkForeignIOF hIsEOF + IO_isFileOpen_impl_v3 -> mkForeignIOF hIsOpen + IO_getEcho_impl_v1 -> mkForeignIOF hGetEcho + IO_ready_impl_v1 -> mkForeignIOF hReady + IO_getChar_impl_v1 -> mkForeignIOF hGetChar + IO_isSeekable_impl_v3 -> mkForeignIOF hIsSeekable + IO_seekHandle_impl_v3 -> mkForeignIOF $ + \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) + IO_handlePosition_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \h -> fromInteger @Word64 <$> hTell h + IO_getBuffering_impl_v3 -> mkForeignIOF hGetBuffering + IO_setBuffering_impl_v3 -> + mkForeignIOF $ + uncurry hSetBuffering + IO_setEcho_impl_v1 -> mkForeignIOF $ uncurry hSetEcho + IO_getLine_impl_v1 -> + mkForeignIOF $ + fmap Util.Text.fromText . Text.IO.hGetLine + IO_getBytes_impl_v3 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGet h n + IO_getSomeBytes_impl_v1 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGetSome h n + IO_putBytes_impl_v3 -> mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + IO_systemTime_impl_v3 -> mkForeignIOF $ + \() -> getPOSIXTime + IO_systemTimeMicroseconds_v1 -> mkForeign $ + \() -> fmap (1e6 *) getPOSIXTime + Clock_internals_monotonic_v1 -> mkForeignIOF $ + \() -> getTime Monotonic + Clock_internals_realtime_v1 -> mkForeignIOF $ + \() -> getTime Realtime + Clock_internals_processCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ProcessCPUTime + Clock_internals_threadCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ThreadCPUTime + Clock_internals_sec_v1 -> mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) + Clock_internals_nsec_v1 -> mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) + Clock_internals_systemTimeZone_v1 -> + mkForeign + ( \secs -> do + TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) + pure (offset :: Int, summer, name) + ) + IO_getTempDirectory_impl_v3 -> + mkForeignIOF $ + \() -> chop <$> getTemporaryDirectory + IO_createTempDirectory_impl_v3 -> mkForeignIOF $ \prefix -> do + temp <- getTemporaryDirectory + chop <$> createTempDirectory temp prefix + IO_getCurrentDirectory_impl_v3 -> mkForeignIOF $ + \() -> getCurrentDirectory + IO_setCurrentDirectory_impl_v3 -> mkForeignIOF setCurrentDirectory + IO_fileExists_impl_v3 -> mkForeignIOF doesPathExist + IO_getEnv_impl_v1 -> mkForeignIOF getEnv + IO_getArgs_impl_v1 -> mkForeignIOF $ + \() -> fmap Util.Text.pack <$> SYS.getArgs + IO_isDirectory_impl_v3 -> mkForeignIOF doesDirectoryExist + IO_createDirectory_impl_v3 -> + mkForeignIOF $ + createDirectoryIfMissing True + IO_removeDirectory_impl_v3 -> mkForeignIOF removeDirectoryRecursive + IO_renameDirectory_impl_v3 -> + mkForeignIOF $ + uncurry renameDirectory + IO_directoryContents_impl_v3 -> + mkForeignIOF $ + (fmap Util.Text.pack <$>) . getDirectoryContents + IO_removeFile_impl_v3 -> mkForeignIOF removeFile + IO_renameFile_impl_v3 -> + mkForeignIOF $ + uncurry renameFile + IO_getFileTimestamp_impl_v3 -> + mkForeignIOF $ + fmap utcTimeToPOSIXSeconds . getModificationTime + IO_getFileSize_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \fp -> fromInteger @Word64 <$> getFileSize fp + IO_serverSocket_impl_v3 -> + mkForeignIOF $ + \( mhst :: Maybe Util.Text.Text, + port + ) -> + fst <$> SYS.bindSock (hostPreference mhst) port + Socket_toText -> mkForeign $ + \(sock :: Socket) -> pure $ show sock + Handle_toText -> mkForeign $ + \(hand :: Handle) -> pure $ show hand + ThreadId_toText -> mkForeign $ + \(threadId :: ThreadId) -> pure $ show threadId + IO_socketPort_impl_v3 -> mkForeignIOF $ + \(handle :: Socket) -> do + n <- SYS.socketPort handle + return (fromIntegral n :: Word64) + IO_listen_impl_v3 -> mkForeignIOF $ + \sk -> SYS.listenSock sk 2048 + IO_clientSocket_impl_v3 -> + mkForeignIOF $ + fmap fst . uncurry SYS.connectSock + IO_closeSocket_impl_v3 -> mkForeignIOF SYS.closeSock + IO_socketAccept_impl_v3 -> + mkForeignIOF $ + fmap fst . SYS.accept + IO_socketSend_impl_v3 -> mkForeignIOF $ + \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + IO_socketReceive_impl_v3 -> mkForeignIOF $ + \(hs, n) -> + maybe mempty Bytes.fromArray <$> SYS.recv hs n + IO_kill_impl_v3 -> mkForeignIOF killThread + IO_delay_impl_v3 -> mkForeignIOF customDelay + IO_stdHandle -> mkForeign $ + \(n :: Int) -> case n of + 0 -> pure SYS.stdin + 1 -> pure SYS.stdout + 2 -> pure SYS.stderr + _ -> die "IO.stdHandle: invalid input." + IO_process_call -> mkForeign $ + \(exe, map Util.Text.unpack -> args) -> + withCreateProcess (proc exe args) $ \_ _ _ p -> + exitDecode <$> waitForProcess p + IO_process_start -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> + runInteractiveProcess exe args Nothing Nothing + IO_process_kill -> mkForeign $ terminateProcess + IO_process_wait -> mkForeign $ + \ph -> exitDecode <$> waitForProcess ph + IO_process_exitCode -> + mkForeign $ + fmap (fmap exitDecode) . getProcessExitCode + MVar_new -> mkForeign $ + \(c :: Val) -> newMVar c + MVar_newEmpty_v2 -> mkForeign $ + \() -> newEmptyMVar @Val + MVar_take_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> takeMVar mv + MVar_tryTake -> mkForeign $ + \(mv :: MVar Val) -> tryTakeMVar mv + MVar_put_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> putMVar mv x + MVar_tryPut_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> tryPutMVar mv x + MVar_swap_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> swapMVar mv x + MVar_isEmpty -> mkForeign $ + \(mv :: MVar Val) -> isEmptyMVar mv + MVar_read_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> readMVar mv + MVar_tryRead_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> tryReadMVar mv + Char_toText -> mkForeign $ + \(ch :: Char) -> pure (Util.Text.singleton ch) + Text_repeat -> mkForeign $ + \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + Text_reverse -> + mkForeign $ + pure . Util.Text.reverse + Text_toUppercase -> + mkForeign $ + pure . Util.Text.toUppercase + Text_toLowercase -> + mkForeign $ + pure . Util.Text.toLowercase + Text_toUtf8 -> + mkForeign $ + pure . Util.Text.toUtf8 + Text_fromUtf8_impl_v3 -> + mkForeign $ + pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + Tls_ClientConfig_default -> mkForeign $ + \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> + fmap + ( \store -> + (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) + { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.clientShared = def {TLS.sharedCAStore = store} + } + ) + X.getSystemCertificateStore + Tls_ServerConfig_default -> + mkForeign $ + \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> + pure $ + (def :: TLS.ServerParams) + { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} + } + Tls_ClientConfig_certificates_set -> + let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams + updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + Tls_ServerConfig_certificates_set -> + let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams + updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + TVar_new -> mkForeign $ + \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + TVar_read -> mkForeign $ + \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + TVar_write -> mkForeign $ + \(v :: STM.TVar Val, c :: Val) -> + unsafeSTMToIO $ STM.writeTVar v c + TVar_newIO -> mkForeign $ + \(c :: Val) -> STM.newTVarIO c + TVar_readIO -> mkForeign $ + \(v :: STM.TVar Val) -> STM.readTVarIO v + TVar_swap -> mkForeign $ + \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + STM_retry -> mkForeign $ + \() -> unsafeSTMToIO STM.retry :: IO Val + Promise_new -> mkForeign $ + \() -> newPromise @Val + Promise_read -> mkForeign $ + \(p :: Promise Val) -> readPromise p + Promise_tryRead -> mkForeign $ + \(p :: Promise Val) -> tryReadPromise p + Promise_write -> mkForeign $ + \(p :: Promise Val, a :: Val) -> writePromise p a + Tls_newClient_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ClientParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_newServer_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ServerParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_handshake_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.handshake tls + Tls_send_impl_v3 -> + mkForeignTls $ + \( tls :: TLS.Context, + bytes :: Bytes.Bytes + ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) + Tls_decodeCert_impl_v3 -> undefined + Tls_encodeCert -> undefined + Tls_decodePrivateKey -> undefined + Tls_encodePrivateKey -> undefined + Tls_receive_impl_v3 -> undefined + Tls_terminate_impl_v3 -> undefined + Code_validateLinks -> undefined + Code_dependencies -> undefined + Code_serialize -> undefined + Code_deserialize -> undefined + Code_display -> undefined + Value_dependencies -> undefined + Value_serialize -> undefined + Value_deserialize -> undefined + Crypto_HashAlgorithm_Sha3_512 -> undefined + Crypto_HashAlgorithm_Sha3_256 -> undefined + Crypto_HashAlgorithm_Sha2_512 -> undefined + Crypto_HashAlgorithm_Sha2_256 -> undefined + Crypto_HashAlgorithm_Sha1 -> undefined + Crypto_HashAlgorithm_Blake2b_512 -> undefined + Crypto_HashAlgorithm_Blake2b_256 -> undefined + Crypto_HashAlgorithm_Blake2s_256 -> undefined + Crypto_HashAlgorithm_Md5 -> undefined + Crypto_hashBytes -> undefined + Crypto_hmacBytes -> undefined + Crypto_hash -> undefined + Crypto_hmac -> undefined + Crypto_Ed25519_sign_impl -> undefined + Crypto_Ed25519_verify_impl -> undefined + Crypto_Rsa_sign_impl -> undefined + Crypto_Rsa_verify_impl -> undefined + Universal_murmurHash -> undefined + IO_randomBytes -> undefined + Bytes_zlib_compress -> undefined + Bytes_gzip_compress -> undefined + Bytes_zlib_decompress -> undefined + Bytes_gzip_decompress -> undefined + Bytes_toBase16 -> undefined + Bytes_toBase32 -> undefined + Bytes_toBase64 -> undefined + Bytes_toBase64UrlUnpadded -> undefined + Bytes_fromBase16 -> undefined + Bytes_fromBase32 -> undefined + Bytes_fromBase64 -> undefined + Bytes_fromBase64UrlUnpadded -> undefined + Bytes_decodeNat64be -> undefined + Bytes_decodeNat64le -> undefined + Bytes_decodeNat32be -> undefined + Bytes_decodeNat32le -> undefined + Bytes_decodeNat16be -> undefined + Bytes_decodeNat16le -> undefined + Bytes_encodeNat64be -> undefined + Bytes_encodeNat64le -> undefined + Bytes_encodeNat32be -> undefined + Bytes_encodeNat32le -> undefined + Bytes_encodeNat16be -> undefined + Bytes_encodeNat16le -> undefined + MutableArray_copyTo_force -> undefined + MutableByteArray_copyTo_force -> undefined + ImmutableArray_copyTo_force -> undefined + ImmutableArray_size -> undefined + MutableArray_size -> undefined + ImmutableByteArray_size -> undefined + MutableByteArray_size -> undefined + ImmutableByteArray_copyTo_force -> undefined + MutableArray_read -> undefined + MutableByteArray_read8 -> undefined + MutableByteArray_read16be -> undefined + MutableByteArray_read24be -> undefined + MutableByteArray_read32be -> undefined + MutableByteArray_read40be -> undefined + MutableByteArray_read64be -> undefined + MutableArray_write -> undefined + MutableByteArray_write8 -> undefined + MutableByteArray_write16be -> undefined + MutableByteArray_write32be -> undefined + MutableByteArray_write64be -> undefined + ImmutableArray_read -> undefined + ImmutableByteArray_read8 -> undefined + ImmutableByteArray_read16be -> undefined + ImmutableByteArray_read24be -> undefined + ImmutableByteArray_read32be -> undefined + ImmutableByteArray_read40be -> undefined + ImmutableByteArray_read64be -> undefined + MutableByteArray_freeze_force -> undefined + MutableArray_freeze_force -> undefined + MutableByteArray_freeze -> undefined + MutableArray_freeze -> undefined + MutableByteArray_length -> undefined + ImmutableByteArray_length -> undefined + IO_array -> undefined + IO_arrayOf -> undefined + IO_bytearray -> undefined + IO_bytearrayOf -> undefined + Scope_array -> undefined + Scope_arrayOf -> undefined + Scope_bytearray -> undefined + Scope_bytearrayOf -> undefined + Text_patterns_literal -> undefined + Text_patterns_digit -> undefined + Text_patterns_letter -> undefined + Text_patterns_space -> undefined + Text_patterns_punctuation -> undefined + Text_patterns_anyChar -> undefined + Text_patterns_eof -> undefined + Text_patterns_charRange -> undefined + Text_patterns_notCharRange -> undefined + Text_patterns_charIn -> undefined + Text_patterns_notCharIn -> undefined + Pattern_many -> undefined + Pattern_many_corrected -> undefined + Pattern_capture -> undefined + Pattern_captureAs -> undefined + Pattern_join -> undefined + Pattern_or -> undefined + Pattern_replicate -> undefined + Pattern_run -> undefined + Pattern_isMatch -> undefined + Char_Class_any -> undefined + Char_Class_not -> undefined + Char_Class_and -> undefined + Char_Class_or -> undefined + Char_Class_range -> undefined + Char_Class_anyOf -> undefined + Char_Class_alphanumeric -> undefined + Char_Class_upper -> undefined + Char_Class_lower -> undefined + Char_Class_whitespace -> undefined + Char_Class_control -> undefined + Char_Class_printable -> undefined + Char_Class_mark -> undefined + Char_Class_number -> undefined + Char_Class_punctuation -> undefined + Char_Class_symbol -> undefined + Char_Class_separator -> undefined + Char_Class_letter -> undefined + Char_Class_is -> undefined + Text_patterns_char -> undefined + where + chop = reverse . dropWhile isPathSeparator . reverse + + hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference + hostPreference Nothing = SYS.HostAny + hostPreference (Just host) = SYS.Host $ Util.Text.unpack host + + mx :: Word64 + mx = fromIntegral (maxBound :: Int) + + customDelay :: Word64 -> IO () + customDelay n + | n < mx = threadDelay (fromIntegral n) + | otherwise = threadDelay maxBound >> customDelay (n - mx) + + exitDecode ExitSuccess = 0 + exitDecode (ExitFailure n) = n +{-# INLINE foreignCall #-} + +mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack +mkForeign f args stk = do + args <- decodeArgs args stk + res <- f args + writeForeign stk res + where + decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x + decodeArgs args stk = + readForeign (argsToLists args) stk >>= \case + ([], a) -> pure a + _ -> + error + "mkForeign: too many arguments for foreign function" +{-# INLINE mkForeign #-} + +mkForeignIOF :: + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) + where + tryIOE :: IO a -> IO (Either (F.Failure Val) a) + tryIOE = fmap handleIOE . UnliftIO.try + handleIOE :: Either IOException a -> Either (F.Failure Val) a + handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Right a) = Right a +{-# INLINE mkForeignIOF #-} + +mkForeignTls :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO r -> IO (Either TLS.TLSException r) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r + flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right a)) = Right a + +mkForeignTlsE :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO (Either (F.Failure Val) r)) -> + Args -> + Stack -> + IO Stack +mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO (Either (F.Failure Val) r) -> IO (Either TLS.TLSException (Either (F.Failure Val) r)) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException (Either (F.Failure Val) r)) -> IO (Either IOException (Either TLS.TLSException (Either (F.Failure Val) r))) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException (Either (F.Failure Val) r)) -> Either (F.Failure Val) r + flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right (Left e))) = Left e + flatten (Right (Right (Right a))) = Right a + +unsafeSTMToIO :: STM.STM a -> IO a +unsafeSTMToIO (STM.STM m) = IO m diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index b307c8a935..010513d481 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -35,6 +35,7 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, + ForeignFunc' (..), emitCombs, emitComb, resolveCombs, @@ -459,6 +460,256 @@ data BPrim2 | REFW -- Ref.write deriving (Show, Eq, Ord, Enum, Bounded) +-- | Enum representing every foreign call. +data ForeignFunc' + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + data MLit = MI !Int | MN !Word64 @@ -503,6 +754,11 @@ data GInstr comb !Bool -- catch exceptions !Word64 -- FFI call !Args -- arguments + | -- Call out to a Haskell function. + ForeignCall' + !Bool -- catch exceptions + !ForeignFunc' -- FFI call + !Args -- arguments | -- Set the value of a dynamic reference SetDyn !Word64 -- the prompt tag of the reference diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 596f355353..b6f6cf66b3 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -24,6 +24,7 @@ import Data.Traversable import GHC.Conc as STM (unsafeIOToSTM) import Unison.Builtin.Decls (exceptionRef, ioFailureRef) import Unison.Builtin.Decls qualified as Rf +import Unison.Builtin.Decls qualified as Ty import Unison.ConstructorReference qualified as CR import Unison.Prelude hiding (Text) import Unison.Reference @@ -51,6 +52,7 @@ import Unison.Runtime.Array as PA import Unison.Runtime.Builtin import Unison.Runtime.Exception import Unison.Runtime.Foreign +import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function import Unison.Runtime.MCode import Unison.Runtime.Stack @@ -289,8 +291,13 @@ jump0 !callback !env !activeThreads !clo = do where k0 = CB (Hook callback) -unitValue :: Closure -unitValue = Enum Rf.unitRef TT.unitTag +unitValue :: Val +unitValue = BoxedVal $ unitClosure +{-# NOINLINE unitValue #-} + +unitClosure :: Closure +unitClosure = Enum Ty.unitRef (PackedTag 0) +{-# NOINLINE unitClosure #-} lookupDenv :: Word64 -> DEnv -> Val lookupDenv p denv = fromMaybe (BoxedVal BlackHole) $ EC.lookup p denv @@ -601,6 +608,8 @@ exec !env !denv !_activeThreads !stk !k _ (ForeignCall _ w args) <$> (arg stk args >>= ev >>= res stk) | otherwise = die $ "reference to unknown foreign function: " ++ show w +exec !_env !denv !_activeThreads !stk !k _ (ForeignCall' _ func args) = + (denv,,k) <$> foreignCall args func stk exec !env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do @@ -648,22 +657,22 @@ encodeExn stk exc = do disp e = Util.Text.pack $ show e (link, msg, extra) | Just (ioe :: IOException) <- fromException exn = - (Rf.ioFailureRef, disp ioe, boxedVal unitValue) + (Rf.ioFailureRef, disp ioe, unitValue) | Just re <- fromException exn = case re of PE _stk msg -> - (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, boxedVal unitValue) + (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue) BU _ tx val -> (Rf.runtimeFailureRef, Util.Text.fromText tx, val) | Just (ae :: ArithException) <- fromException exn = - (Rf.arithmeticFailureRef, disp ae, boxedVal unitValue) + (Rf.arithmeticFailureRef, disp ae, unitValue) | Just (nae :: NestedAtomically) <- fromException exn = - (Rf.stmFailureRef, disp nae, boxedVal unitValue) + (Rf.stmFailureRef, disp nae, unitValue) | Just (be :: BlockedIndefinitelyOnSTM) <- fromException exn = - (Rf.stmFailureRef, disp be, boxedVal unitValue) + (Rf.stmFailureRef, disp be, unitValue) | Just (be :: BlockedIndefinitelyOnMVar) <- fromException exn = - (Rf.ioFailureRef, disp be, boxedVal unitValue) + (Rf.ioFailureRef, disp be, unitValue) | Just (ie :: AsyncException) <- fromException exn = - (Rf.threadKilledFailureRef, disp ie, boxedVal unitValue) - | otherwise = (Rf.miscFailureRef, disp exn, boxedVal unitValue) + (Rf.threadKilledFailureRef, disp ie, unitValue) + | otherwise = (Rf.miscFailureRef, disp exn, unitValue) numValue :: Maybe Reference -> Val -> IO Word64 numValue _ (UnboxedVal v _) = pure (fromIntegral @Int @Word64 v) @@ -1937,7 +1946,7 @@ bprim2 !stk REFW i j = do v <- peekOff stk j IORef.writeIORef ref v stk <- bump stk - bpoke stk unitValue + bpoke stk unitClosure pure stk bprim2 !stk THRO _ _ = pure stk -- impossible bprim2 !stk TRCE _ _ = pure stk -- impossible diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index a23132a3f9..7b1eb787b3 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -44,6 +44,7 @@ library Unison.Runtime.Exception Unison.Runtime.Foreign Unison.Runtime.Foreign.Function + Unison.Runtime.Foreign.Impl Unison.Runtime.Interface Unison.Runtime.IOSource Unison.Runtime.Machine From cae64d7f0850848f70eab6d9b2a20ce7e1ab3d17 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 22:32:56 -0800 Subject: [PATCH 3/6] Finish porting over foreign calls --- unison-runtime/src/Unison/Runtime/Builtin.hs | 699 ++++--------- .../src/Unison/Runtime/Foreign/Impl.hs | 915 +++++++++++++++--- 2 files changed, 940 insertions(+), 674 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 2a015691d0..1a65902dd9 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -21,6 +21,8 @@ module Unison.Runtime.Builtin Sandbox (..), baseSandboxInfo, unitValue, + natValue, + builtinForeignNames, ) where @@ -2330,462 +2332,180 @@ declareForeigns = do declareForeign' Tracked "Promise.write" (argNDirect 2) Promise_write declareForeign' Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 - declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ - \( config :: TLS.ServerParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.handshake tls - - declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 . mkForeignTls $ - \( tls :: TLS.Context, - bytes :: Bytes.Bytes - ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - - let wrapFailure t = Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue - decoded :: Bytes.Bytes -> Either String PEM - decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of - Right (pem : _) -> Right pem - Right [] -> Left "no PEM found" - Left l -> Left l - asCert :: PEM -> Either String X.SignedCertificate - asCert pem = X.decodeSignedCertificate $ pemContent pem - in declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF . mkForeignTlsE $ - \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes - - declareForeign Tracked "Tls.encodeCert" (argNDirect 1) . mkForeign $ - \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert - - declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) . mkForeign $ - \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes - - declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) . mkForeign $ - \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey - - declareForeign Tracked "Tls.receive.impl.v3" argToEF . mkForeignTls $ - \(tls :: TLS.Context) -> do - bs <- TLS.recvData tls - pure $ Bytes.fromArray bs - - declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.bye tls - - declareForeign Untracked "Code.validateLinks" argToExnE - . mkForeign - $ \(lsgs0 :: [(Referent, Code)]) -> do - let f (msg, rs) = - Failure Ty.miscFailureRef (Util.Text.fromText msg) rs - pure . first f $ checkGroupHashes lsgs0 - declareForeign Untracked "Code.dependencies" (argNDirect 1) - . mkForeign - $ \(CodeRep sg _) -> - pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg - declareForeign Untracked "Code.serialize" (argNDirect 1) - . mkForeign - $ \(co :: Code) -> - pure . Bytes.fromArray $ serializeCode builtinForeignNames co - declareForeign Untracked "Code.deserialize" argToEither - . mkForeign - $ pure . deserializeCode . Bytes.toArray - declareForeign Untracked "Code.display" (argNDirect 2) . mkForeign $ - \(nm, (CodeRep sg _)) -> - pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" - declareForeign Untracked "Value.dependencies" (argNDirect 1) - . mkForeign - $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks - declareForeign Untracked "Value.serialize" (argNDirect 1) - . mkForeign - $ pure . Bytes.fromArray . serializeValue - declareForeign Untracked "Value.deserialize" argToEither - . mkForeign - $ pure . deserializeValue . Bytes.toArray + declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 + declareForeign' Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 + declareForeign' Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 + declareForeign' Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 + + declareForeign' Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert + + declareForeign' Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey + declareForeign' Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey + + declareForeign' Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 + + declareForeign' Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 + declareForeign' Untracked "Code.validateLinks" argToExnE Code_validateLinks + declareForeign' Untracked "Code.dependencies" (argNDirect 1) Code_dependencies + declareForeign' Untracked "Code.serialize" (argNDirect 1) Code_serialize + declareForeign' Untracked "Code.deserialize" argToEither Code_deserialize + declareForeign' Untracked "Code.display" (argNDirect 2) Code_display + declareForeign' Untracked "Value.dependencies" (argNDirect 1) Value_dependencies + declareForeign' Untracked "Value.serialize" (argNDirect 1) Value_serialize + declareForeign' Untracked "Value.deserialize" argToEither Value_deserialize -- Hashing functions - let declareHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> FDecl Symbol () - declareHashAlgorithm txt alg = do - let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) - declareForeign Untracked ("crypto.HashAlgorithm." <> txt) direct . mkForeign $ \() -> - pure (HashAlgorithm algoRef alg) - - declareHashAlgorithm "Sha3_512" Hash.SHA3_512 - declareHashAlgorithm "Sha3_256" Hash.SHA3_256 - declareHashAlgorithm "Sha2_512" Hash.SHA512 - declareHashAlgorithm "Sha2_256" Hash.SHA256 - declareHashAlgorithm "Sha1" Hash.SHA1 - declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512 - declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256 - declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256 - declareHashAlgorithm "Md5" Hash.MD5 - - declareForeign Untracked "crypto.hashBytes" (argNDirect 2) . mkForeign $ - \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> - let ctx = Hash.hashInitWith alg - in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) - - declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) - . mkForeign - $ \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> - let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) - u :: a -> HMAC.HMAC a -> HMAC.HMAC a - u _ h = h -- to help typechecker along - in pure $ Bytes.fromArray out - - declareForeign Untracked "crypto.hash" crypto'hash . mkForeign $ - \(HashAlgorithm _ alg, x) -> - let hashlazy :: - (Hash.HashAlgorithm a) => - a -> - L.ByteString -> - Hash.Digest a - hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x - - declareForeign Untracked "crypto.hmac" crypto'hmac . mkForeign $ - \(HashAlgorithm _ alg, key, x) -> - let hmac :: - (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a - hmac _ s = - HMAC.finalize - . HMAC.updates - (HMAC.initialize $ Bytes.toArray @BA.Bytes key) - $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x - - declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF - . mkForeign - $ pure . signEd25519Wrapper - - declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool - . mkForeign - $ pure . verifyEd25519Wrapper - - declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF - . mkForeign - $ pure . signRsaWrapper - - declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool - . mkForeign - $ pure . verifyRsaWrapper - - let catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) - catchAll e = do - e <- Exception.tryAnyDeep e - pure $ case e of - Left se -> Left (Util.Text.pack (show se)) - Right a -> Right a - - declareForeign Untracked "Universal.murmurHash" murmur'hash . mkForeign $ - pure . asWord64 . hash64 . serializeValueForHash - - declareForeign Tracked "IO.randomBytes" (argNDirect 1) . mkForeign $ - \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n - - declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) . mkForeign $ pure . Bytes.zlibCompress - declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) . mkForeign $ pure . Bytes.gzipCompress - declareForeign Untracked "Bytes.zlib.decompress" argToEither . mkForeign $ \bs -> - catchAll (pure (Bytes.zlibDecompress bs)) - declareForeign Untracked "Bytes.gzip.decompress" argToEither . mkForeign $ \bs -> - catchAll (pure (Bytes.gzipDecompress bs)) - - declareForeign Untracked "Bytes.toBase16" (argNDirect 1) . mkForeign $ pure . Bytes.toBase16 - declareForeign Untracked "Bytes.toBase32" (argNDirect 1) . mkForeign $ pure . Bytes.toBase32 - declareForeign Untracked "Bytes.toBase64" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64UrlUnpadded - - declareForeign Untracked "Bytes.fromBase16" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase16 - declareForeign Untracked "Bytes.fromBase32" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase32 - declareForeign Untracked "Bytes.fromBase64" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - - declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ - Right - <$> PA.copyMutableArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ - Right - <$> PA.copyMutableByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofArray src) (soff + l - 1) $ - Right - <$> PA.copyArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val - declareForeign Untracked "MutableArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val - declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofByteArray - declareForeign Untracked "MutableByteArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ - Right - <$> PA.copyByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableArray.read" arg2ToExn - . mkForeign - $ checkedRead "MutableArray.read" - declareForeign Untracked "MutableByteArray.read8" arg2ToExn - . mkForeign - $ checkedRead8 "MutableByteArray.read8" - declareForeign Untracked "MutableByteArray.read16be" arg2ToExn - . mkForeign - $ checkedRead16 "MutableByteArray.read16be" - declareForeign Untracked "MutableByteArray.read24be" arg2ToExn - . mkForeign - $ checkedRead24 "MutableByteArray.read24be" - declareForeign Untracked "MutableByteArray.read32be" arg2ToExn - . mkForeign - $ checkedRead32 "MutableByteArray.read32be" - declareForeign Untracked "MutableByteArray.read40be" arg2ToExn - . mkForeign - $ checkedRead40 "MutableByteArray.read40be" - declareForeign Untracked "MutableByteArray.read64be" arg2ToExn - . mkForeign - $ checkedRead64 "MutableByteArray.read64be" - - declareForeign Untracked "MutableArray.write" arg3ToExnUnit - . mkForeign - $ checkedWrite "MutableArray.write" - declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit - . mkForeign - $ checkedWrite8 "MutableByteArray.write8" - declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit - . mkForeign - $ checkedWrite16 "MutableByteArray.write16be" - declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit - . mkForeign - $ checkedWrite32 "MutableByteArray.write32be" - declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit - . mkForeign - $ checkedWrite64 "MutableByteArray.write64be" - - declareForeign Untracked "ImmutableArray.read" arg2ToExn - . mkForeign - $ checkedIndex "ImmutableArray.read" - declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn - . mkForeign - $ checkedIndex8 "ImmutableByteArray.read8" - declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn - . mkForeign - $ checkedIndex16 "ImmutableByteArray.read16be" - declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn - . mkForeign - $ checkedIndex24 "ImmutableByteArray.read24be" - declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn - . mkForeign - $ checkedIndex32 "ImmutableByteArray.read32be" - declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn - . mkForeign - $ checkedIndex40 "ImmutableByteArray.read40be" - declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn - . mkForeign - $ checkedIndex64 "ImmutableByteArray.read64be" - - declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) . mkForeign $ - PA.unsafeFreezeByteArray - declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) . mkForeign $ - PA.unsafeFreezeArray @IO @Val - - declareForeign Untracked "MutableByteArray.freeze" arg3ToExn . mkForeign $ - \(src, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 - else - checkBoundsPrim - "MutableByteArray.freeze" - (PA.sizeofMutableByteArray src) - (off + len) - 0 - $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableArray.freeze" arg3ToExn . mkForeign $ - \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal - else - checkBounds - "MutableArray.freeze" - (PA.sizeofMutableArray src) - (off + len - 1) - $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableByteArray.length" (argNDirect 1) . mkForeign $ - pure . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) . mkForeign $ - pure . PA.sizeofByteArray - - declareForeign Tracked "IO.array" (argNDirect 1) . mkForeign $ - \n -> PA.newArray n emptyVal - declareForeign Tracked "IO.arrayOf" (argNDirect 2) . mkForeign $ - \(v :: Val, n) -> PA.newArray n v - declareForeign Tracked "IO.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray - declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Scope.array" (argNDirect 1) . mkForeign $ - \n -> PA.newArray n emptyVal - declareForeign Untracked "Scope.arrayOf" (argNDirect 2) . mkForeign $ - \(v :: Val, n) -> PA.newArray n v - declareForeign Untracked "Scope.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray - declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Text.patterns.literal" (argNDirect 1) . mkForeign $ - \txt -> evaluate . TPat.cpattern $ TPat.Literal txt - declareForeign Untracked "Text.patterns.digit" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v - declareForeign Untracked "Text.patterns.letter" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v - declareForeign Untracked "Text.patterns.space" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v - declareForeign Untracked "Text.patterns.punctuation" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v - declareForeign Untracked "Text.patterns.anyChar" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v - declareForeign Untracked "Text.patterns.eof" direct . mkForeign $ - let v = TPat.cpattern TPat.Eof in \() -> pure v - declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs - declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.notCharIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs - declareForeign Untracked "Pattern.many" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p - declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p - declareForeign Untracked "Pattern.capture" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p - declareForeign Untracked "Pattern.captureAs" (argNDirect 2) . mkForeign $ - \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p - declareForeign Untracked "Pattern.join" (argNDirect 1) . mkForeign $ \ps -> - evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - declareForeign Untracked "Pattern.or" (argNDirect 2) . mkForeign $ - \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r - declareForeign Untracked "Pattern.replicate" (argNDirect 3) . mkForeign $ - \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> - let m = fromIntegral m0; n = fromIntegral n0 - in evaluate . TPat.cpattern $ TPat.Replicate m n p - - declareForeign Untracked "Pattern.run" arg2ToMaybeTup . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - - declareForeign Untracked "Pattern.isMatch" (argNDirect 2) . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input - - declareForeign Untracked "Char.Class.any" direct . mkForeign $ \() -> pure TPat.Any - declareForeign Untracked "Char.Class.not" (argNDirect 1) . mkForeign $ pure . TPat.Not - declareForeign Untracked "Char.Class.and" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Intersect a b - declareForeign Untracked "Char.Class.or" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Union a b - declareForeign Untracked "Char.Class.range" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.CharRange a b - declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate $ TPat.CharSet cs - declareForeign Untracked "Char.Class.alphanumeric" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) - declareForeign Untracked "Char.Class.upper" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) - declareForeign Untracked "Char.Class.lower" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) - declareForeign Untracked "Char.Class.whitespace" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) - declareForeign Untracked "Char.Class.control" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Control) - declareForeign Untracked "Char.Class.printable" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) - declareForeign Untracked "Char.Class.mark" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) - declareForeign Untracked "Char.Class.number" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Number) - declareForeign Untracked "Char.Class.punctuation" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) - declareForeign Untracked "Char.Class.symbol" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) - declareForeign Untracked "Char.Class.separator" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) - declareForeign Untracked "Char.Class.letter" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) - declareForeign Untracked "Char.Class.is" (argNDirect 2) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c - declareForeign Untracked "Text.patterns.char" (argNDirect 1) . mkForeign $ \c -> - let v = TPat.cpattern (TPat.Char c) in pure v + declareForeign' Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 + declareForeign' Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 + declareForeign' Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 + declareForeign' Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 + declareForeign' Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 + declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign' Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign' Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 + + declareForeign' Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes + declareForeign' Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes + + declareForeign' Untracked "crypto.hash" crypto'hash Crypto_hash + declareForeign' Untracked "crypto.hmac" crypto'hmac Crypto_hmac + declareForeign' Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign' Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign' Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl + + declareForeign' Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign' Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash + declareForeign' Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes + declareForeign' Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress + declareForeign' Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress + declareForeign' Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress + declareForeign' Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress + + declareForeign' Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 + declareForeign' Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 + declareForeign' Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 + declareForeign' Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign' Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 + declareForeign' Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 + declareForeign' Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 + declareForeign' Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded + + declareForeign' Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be + declareForeign' Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le + declareForeign' Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be + declareForeign' Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le + declareForeign' Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be + declareForeign' Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le + + declareForeign' Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be + declareForeign' Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le + declareForeign' Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be + declareForeign' Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le + declareForeign' Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be + declareForeign' Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le + + declareForeign' Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force + + declareForeign' Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign' Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign' Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size + declareForeign' Untracked "MutableArray.size" (argNDirect 1) MutableArray_size + declareForeign' Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size + declareForeign' Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size + + declareForeign' Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign' Untracked "MutableArray.read" arg2ToExn MutableArray_read + declareForeign' Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 + declareForeign' Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be + declareForeign' Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be + declareForeign' Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be + declareForeign' Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be + declareForeign' Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be + + declareForeign' Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write + declareForeign' Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 + declareForeign' Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be + declareForeign' Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be + declareForeign' Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be + + declareForeign' Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read + declareForeign' Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 + declareForeign' Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be + declareForeign' Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be + declareForeign' Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be + declareForeign' Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be + declareForeign' Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be + + declareForeign' Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force + declareForeign' Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force + + declareForeign' Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze + declareForeign' Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze + + declareForeign' Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length + + declareForeign' Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length + + declareForeign' Tracked "IO.array" (argNDirect 1) IO_array + declareForeign' Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf + declareForeign' Tracked "IO.bytearray" (argNDirect 1) IO_bytearray + declareForeign' Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf + + declareForeign' Untracked "Scope.array" (argNDirect 1) Scope_array + declareForeign' Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf + declareForeign' Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray + declareForeign' Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf + + declareForeign' Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal + declareForeign' Untracked "Text.patterns.digit" direct Text_patterns_digit + declareForeign' Untracked "Text.patterns.letter" direct Text_patterns_letter + declareForeign' Untracked "Text.patterns.space" direct Text_patterns_space + declareForeign' Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation + declareForeign' Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar + declareForeign' Untracked "Text.patterns.eof" direct Text_patterns_eof + declareForeign' Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange + declareForeign' Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange + declareForeign' Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn + declareForeign' Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn + declareForeign' Untracked "Pattern.many" (argNDirect 1) Pattern_many + declareForeign' Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected + declareForeign' Untracked "Pattern.capture" (argNDirect 1) Pattern_capture + declareForeign' Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs + declareForeign' Untracked "Pattern.join" (argNDirect 1) Pattern_join + declareForeign' Untracked "Pattern.or" (argNDirect 2) Pattern_or + declareForeign' Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate + + declareForeign' Untracked "Pattern.run" arg2ToMaybeTup Pattern_run + + declareForeign' Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch + + declareForeign' Untracked "Char.Class.any" direct Char_Class_any + declareForeign' Untracked "Char.Class.not" (argNDirect 1) Char_Class_not + declareForeign' Untracked "Char.Class.and" (argNDirect 2) Char_Class_and + declareForeign' Untracked "Char.Class.or" (argNDirect 2) Char_Class_or + declareForeign' Untracked "Char.Class.range" (argNDirect 2) Char_Class_range + declareForeign' Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf + declareForeign' Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric + declareForeign' Untracked "Char.Class.upper" direct Char_Class_upper + declareForeign' Untracked "Char.Class.lower" direct Char_Class_lower + declareForeign' Untracked "Char.Class.whitespace" direct Char_Class_whitespace + declareForeign' Untracked "Char.Class.control" direct Char_Class_control + declareForeign' Untracked "Char.Class.printable" direct Char_Class_printable + declareForeign' Untracked "Char.Class.mark" direct Char_Class_mark + declareForeign' Untracked "Char.Class.number" direct Char_Class_number + declareForeign' Untracked "Char.Class.punctuation" direct Char_Class_punctuation + declareForeign' Untracked "Char.Class.symbol" direct Char_Class_symbol + declareForeign' Untracked "Char.Class.separator" direct Char_Class_separator + declareForeign' Untracked "Char.Class.letter" direct Char_Class_letter + declareForeign' Untracked "Char.Class.is" (argNDirect 2) Char_Class_is + declareForeign' Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char type RW = PA.PrimState IO @@ -3059,75 +2779,6 @@ checkBoundsPrim name isz off esz act bsz = fromIntegral isz w = off + esz -signEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signEd25519Wrapper (secret0, public0, msg0) = case validated of - CryptoFailed err -> - Left (Failure Ty.cryptoFailureRef (errMsg err) unitValue) - CryptoPassed (secret, public) -> - Right . Bytes.fromArray $ Ed25519.sign secret public msg - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) - <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -verifyEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyEd25519Wrapper (public0, msg0, sig0) = case validated of - CryptoFailed err -> - Left $ Failure Ty.cryptoFailureRef (errMsg err) unitValue - CryptoPassed (public, sig) -> - Right $ Ed25519.verify public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -signRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signRsaWrapper (secret0, msg0) = case validated of - Left err -> - Left (Failure Ty.cryptoFailureRef err unitValue) - Right secret -> - case RSA.sign Nothing (Just Hash.SHA256) secret msg of - Left err -> Left (Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) - Right signature -> Right $ Bytes.fromByteString signature - where - msg = Bytes.toArray msg0 :: ByteString - validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) - -verifyRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyRsaWrapper (public0, msg0, sig0) = case validated of - Left err -> - Left $ Failure Ty.cryptoFailureRef err unitValue - Right public -> - Right $ RSA.verify (Just Hash.SHA256) public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - sig = Bytes.toArray sig0 :: ByteString - validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) - foreignDeclResults :: Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) foreignDeclResults sanitize = diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index d7b58b54eb..f22a6ebcd4 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -142,12 +142,11 @@ import Unison.Runtime.Builtin import Unison.Runtime.Builtin.Types import Unison.Runtime.Crypto.Rsa as Rsa import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign import Unison.Runtime.Foreign ( Foreign (Wrap), HashAlgorithm (..), - pattern Failure, ) +import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function hiding (mkForeign) import Unison.Runtime.MCode @@ -382,7 +381,7 @@ foreignCall = \case pure . Util.Text.toUtf8 Text_fromUtf8_impl_v3 -> mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + pure . mapLeft (\t -> F.Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 Tls_ClientConfig_default -> mkForeign $ \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> fmap @@ -451,144 +450,405 @@ foreignCall = \case \( tls :: TLS.Context, bytes :: Bytes.Bytes ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - Tls_decodeCert_impl_v3 -> undefined - Tls_encodeCert -> undefined - Tls_decodePrivateKey -> undefined - Tls_encodePrivateKey -> undefined - Tls_receive_impl_v3 -> undefined - Tls_terminate_impl_v3 -> undefined - Code_validateLinks -> undefined - Code_dependencies -> undefined - Code_serialize -> undefined - Code_deserialize -> undefined - Code_display -> undefined - Value_dependencies -> undefined - Value_serialize -> undefined - Value_deserialize -> undefined - Crypto_HashAlgorithm_Sha3_512 -> undefined - Crypto_HashAlgorithm_Sha3_256 -> undefined - Crypto_HashAlgorithm_Sha2_512 -> undefined - Crypto_HashAlgorithm_Sha2_256 -> undefined - Crypto_HashAlgorithm_Sha1 -> undefined - Crypto_HashAlgorithm_Blake2b_512 -> undefined - Crypto_HashAlgorithm_Blake2b_256 -> undefined - Crypto_HashAlgorithm_Blake2s_256 -> undefined - Crypto_HashAlgorithm_Md5 -> undefined - Crypto_hashBytes -> undefined - Crypto_hmacBytes -> undefined - Crypto_hash -> undefined - Crypto_hmac -> undefined - Crypto_Ed25519_sign_impl -> undefined - Crypto_Ed25519_verify_impl -> undefined - Crypto_Rsa_sign_impl -> undefined - Crypto_Rsa_verify_impl -> undefined - Universal_murmurHash -> undefined - IO_randomBytes -> undefined - Bytes_zlib_compress -> undefined - Bytes_gzip_compress -> undefined - Bytes_zlib_decompress -> undefined - Bytes_gzip_decompress -> undefined - Bytes_toBase16 -> undefined - Bytes_toBase32 -> undefined - Bytes_toBase64 -> undefined - Bytes_toBase64UrlUnpadded -> undefined - Bytes_fromBase16 -> undefined - Bytes_fromBase32 -> undefined - Bytes_fromBase64 -> undefined - Bytes_fromBase64UrlUnpadded -> undefined - Bytes_decodeNat64be -> undefined - Bytes_decodeNat64le -> undefined - Bytes_decodeNat32be -> undefined - Bytes_decodeNat32le -> undefined - Bytes_decodeNat16be -> undefined - Bytes_decodeNat16le -> undefined - Bytes_encodeNat64be -> undefined - Bytes_encodeNat64le -> undefined - Bytes_encodeNat32be -> undefined - Bytes_encodeNat32le -> undefined - Bytes_encodeNat16be -> undefined - Bytes_encodeNat16le -> undefined - MutableArray_copyTo_force -> undefined - MutableByteArray_copyTo_force -> undefined - ImmutableArray_copyTo_force -> undefined - ImmutableArray_size -> undefined - MutableArray_size -> undefined - ImmutableByteArray_size -> undefined - MutableByteArray_size -> undefined - ImmutableByteArray_copyTo_force -> undefined - MutableArray_read -> undefined - MutableByteArray_read8 -> undefined - MutableByteArray_read16be -> undefined - MutableByteArray_read24be -> undefined - MutableByteArray_read32be -> undefined - MutableByteArray_read40be -> undefined - MutableByteArray_read64be -> undefined - MutableArray_write -> undefined - MutableByteArray_write8 -> undefined - MutableByteArray_write16be -> undefined - MutableByteArray_write32be -> undefined - MutableByteArray_write64be -> undefined - ImmutableArray_read -> undefined - ImmutableByteArray_read8 -> undefined - ImmutableByteArray_read16be -> undefined - ImmutableByteArray_read24be -> undefined - ImmutableByteArray_read32be -> undefined - ImmutableByteArray_read40be -> undefined - ImmutableByteArray_read64be -> undefined - MutableByteArray_freeze_force -> undefined - MutableArray_freeze_force -> undefined - MutableByteArray_freeze -> undefined - MutableArray_freeze -> undefined - MutableByteArray_length -> undefined - ImmutableByteArray_length -> undefined - IO_array -> undefined - IO_arrayOf -> undefined - IO_bytearray -> undefined - IO_bytearrayOf -> undefined - Scope_array -> undefined - Scope_arrayOf -> undefined - Scope_bytearray -> undefined - Scope_bytearrayOf -> undefined - Text_patterns_literal -> undefined - Text_patterns_digit -> undefined - Text_patterns_letter -> undefined - Text_patterns_space -> undefined - Text_patterns_punctuation -> undefined - Text_patterns_anyChar -> undefined - Text_patterns_eof -> undefined - Text_patterns_charRange -> undefined - Text_patterns_notCharRange -> undefined - Text_patterns_charIn -> undefined - Text_patterns_notCharIn -> undefined - Pattern_many -> undefined - Pattern_many_corrected -> undefined - Pattern_capture -> undefined - Pattern_captureAs -> undefined - Pattern_join -> undefined - Pattern_or -> undefined - Pattern_replicate -> undefined - Pattern_run -> undefined - Pattern_isMatch -> undefined - Char_Class_any -> undefined - Char_Class_not -> undefined - Char_Class_and -> undefined - Char_Class_or -> undefined - Char_Class_range -> undefined - Char_Class_anyOf -> undefined - Char_Class_alphanumeric -> undefined - Char_Class_upper -> undefined - Char_Class_lower -> undefined - Char_Class_whitespace -> undefined - Char_Class_control -> undefined - Char_Class_printable -> undefined - Char_Class_mark -> undefined - Char_Class_number -> undefined - Char_Class_punctuation -> undefined - Char_Class_symbol -> undefined - Char_Class_separator -> undefined - Char_Class_letter -> undefined - Char_Class_is -> undefined - Text_patterns_char -> undefined + Tls_decodeCert_impl_v3 -> + let wrapFailure t = F.Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue + decoded :: Bytes.Bytes -> Either String PEM + decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of + Right (pem : _) -> Right pem + Right [] -> Left "no PEM found" + Left l -> Left l + asCert :: PEM -> Either String X.SignedCertificate + asCert pem = X.decodeSignedCertificate $ pemContent pem + in mkForeignTlsE $ + \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes + Tls_encodeCert -> mkForeign $ + \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert + Tls_decodePrivateKey -> mkForeign $ + \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes + Tls_encodePrivateKey -> mkForeign $ + \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey + Tls_receive_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> do + bs <- TLS.recvData tls + pure $ Bytes.fromArray bs + Tls_terminate_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.bye tls + Code_validateLinks -> mkForeign $ + \(lsgs0 :: [(Referent, Code)]) -> do + let f (msg, rs) = + F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs + pure . first f $ checkGroupHashes lsgs0 + Code_dependencies -> mkForeign $ + \(CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg + Code_serialize -> mkForeign $ + \(co :: Code) -> + pure . Bytes.fromArray $ serializeCode builtinForeignNames co + Code_deserialize -> + mkForeign $ + pure . deserializeCode . Bytes.toArray + Code_display -> mkForeign $ + \(nm, (CodeRep sg _)) -> + pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" + Value_dependencies -> + mkForeign $ + pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks + Value_serialize -> + mkForeign $ + pure . Bytes.fromArray . serializeValue + Value_deserialize -> + mkForeign $ + pure . deserializeValue . Bytes.toArray + Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 + Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 + Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 + Crypto_HashAlgorithm_Sha2_256 -> mkHashAlgorithm "Sha2_256" Hash.SHA256 + Crypto_HashAlgorithm_Sha1 -> mkHashAlgorithm "Sha1" Hash.SHA1 + Crypto_HashAlgorithm_Blake2b_512 -> mkHashAlgorithm "Blake2b_512" Hash.Blake2b_512 + Crypto_HashAlgorithm_Blake2b_256 -> mkHashAlgorithm "Blake2b_256" Hash.Blake2b_256 + Crypto_HashAlgorithm_Blake2s_256 -> mkHashAlgorithm "Blake2s_256" Hash.Blake2s_256 + Crypto_HashAlgorithm_Md5 -> mkHashAlgorithm "Md5" Hash.MD5 + Crypto_hashBytes -> mkForeign $ + \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> + let ctx = Hash.hashInitWith alg + in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) + Crypto_hmacBytes -> mkForeign $ + \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> + let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) + u :: a -> HMAC.HMAC a -> HMAC.HMAC a + u _ h = h -- to help typechecker along + in pure $ Bytes.fromArray out + Crypto_hash -> mkForeign $ + \(HashAlgorithm _ alg, x) -> + let hashlazy :: + (Hash.HashAlgorithm a) => + a -> + L.ByteString -> + Hash.Digest a + hashlazy _ l = Hash.hashlazy l + in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x + Crypto_hmac -> mkForeign $ + \(HashAlgorithm _ alg, key, x) -> + let hmac :: + (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a + hmac _ s = + HMAC.finalize + . HMAC.updates + (HMAC.initialize $ Bytes.toArray @BA.Bytes key) + $ L.toChunks s + in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x + Crypto_Ed25519_sign_impl -> + mkForeign $ + pure . signEd25519Wrapper + Crypto_Ed25519_verify_impl -> + mkForeign $ + pure . verifyEd25519Wrapper + Crypto_Rsa_sign_impl -> + mkForeign $ + pure . signRsaWrapper + Crypto_Rsa_verify_impl -> + mkForeign $ + pure . verifyRsaWrapper + Universal_murmurHash -> + mkForeign $ + pure . asWord64 . hash64 . serializeValueForHash + IO_randomBytes -> mkForeign $ + \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n + Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress + Bytes_gzip_compress -> mkForeign $ pure . Bytes.gzipCompress + Bytes_zlib_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + Bytes_gzip_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + Bytes_toBase16 -> mkForeign $ pure . Bytes.toBase16 + Bytes_toBase32 -> mkForeign $ pure . Bytes.toBase32 + Bytes_toBase64 -> mkForeign $ pure . Bytes.toBase64 + Bytes_toBase64UrlUnpadded -> mkForeign $ pure . Bytes.toBase64UrlUnpadded + Bytes_fromBase16 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase16 + Bytes_fromBase32 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase32 + Bytes_fromBase64 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64 + Bytes_fromBase64UrlUnpadded -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded + Bytes_decodeNat64be -> mkForeign $ pure . Bytes.decodeNat64be + Bytes_decodeNat64le -> mkForeign $ pure . Bytes.decodeNat64le + Bytes_decodeNat32be -> mkForeign $ pure . Bytes.decodeNat32be + Bytes_decodeNat32le -> mkForeign $ pure . Bytes.decodeNat32le + Bytes_decodeNat16be -> mkForeign $ pure . Bytes.decodeNat16be + Bytes_decodeNat16le -> mkForeign $ pure . Bytes.decodeNat16le + Bytes_encodeNat64be -> mkForeign $ pure . Bytes.encodeNat64be + Bytes_encodeNat64le -> mkForeign $ pure . Bytes.encodeNat64le + Bytes_encodeNat32be -> mkForeign $ pure . Bytes.encodeNat32be + Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le + Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be + Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le + MutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ + Right + <$> PA.copyMutableArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ + Right + <$> PA.copyMutableByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofArray src) (soff + l - 1) $ + Right + <$> PA.copyArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val + MutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val + ImmutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofByteArray + MutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ + Right + <$> PA.copyByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableArray_read -> + mkForeign $ + checkedRead "MutableArray.read" + MutableByteArray_read8 -> + mkForeign $ + checkedRead8 "MutableByteArray.read8" + MutableByteArray_read16be -> + mkForeign $ + checkedRead16 "MutableByteArray.read16be" + MutableByteArray_read24be -> + mkForeign $ + checkedRead24 "MutableByteArray.read24be" + MutableByteArray_read32be -> + mkForeign $ + checkedRead32 "MutableByteArray.read32be" + MutableByteArray_read40be -> + mkForeign $ + checkedRead40 "MutableByteArray.read40be" + MutableByteArray_read64be -> + mkForeign $ + checkedRead64 "MutableByteArray.read64be" + MutableArray_write -> + mkForeign $ + checkedWrite "MutableArray.write" + MutableByteArray_write8 -> + mkForeign $ + checkedWrite8 "MutableByteArray.write8" + MutableByteArray_write16be -> + mkForeign $ + checkedWrite16 "MutableByteArray.write16be" + MutableByteArray_write32be -> + mkForeign $ + checkedWrite32 "MutableByteArray.write32be" + MutableByteArray_write64be -> + mkForeign $ + checkedWrite64 "MutableByteArray.write64be" + ImmutableArray_read -> + mkForeign $ + checkedIndex "ImmutableArray.read" + ImmutableByteArray_read8 -> + mkForeign $ + checkedIndex8 "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> + mkForeign $ + checkedIndex16 "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> + mkForeign $ + checkedIndex24 "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> + mkForeign $ + checkedIndex32 "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> + mkForeign $ + checkedIndex40 "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> + mkForeign $ + checkedIndex64 "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeByteArray + MutableArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeArray @IO @Val + MutableByteArray_freeze -> mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 + else + checkBoundsPrim + "MutableByteArray.freeze" + (PA.sizeofMutableByteArray src) + (off + len) + 0 + $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) + MutableArray_freeze -> mkForeign $ + \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal + else + checkBounds + "MutableArray.freeze" + (PA.sizeofMutableArray src) + (off + len - 1) + $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) + MutableByteArray_length -> + mkForeign $ + pure . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_length -> + mkForeign $ + pure . PA.sizeofByteArray + IO_array -> mkForeign $ + \n -> PA.newArray n emptyVal + IO_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + IO_bytearray -> mkForeign $ PA.newByteArray + IO_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Scope_array -> mkForeign $ + \n -> PA.newArray n emptyVal + Scope_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + Scope_bytearray -> mkForeign $ PA.newByteArray + Scope_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Text_patterns_literal -> mkForeign $ + \txt -> evaluate . TPat.cpattern $ TPat.Literal txt + Text_patterns_digit -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v + Text_patterns_letter -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v + Text_patterns_space -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v + Text_patterns_punctuation -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v + Text_patterns_anyChar -> + mkForeign $ + let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v + Text_patterns_eof -> + mkForeign $ + let v = TPat.cpattern TPat.Eof in \() -> pure v + Text_patterns_charRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end + Text_patterns_notCharRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end + Text_patterns_charIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs + Text_patterns_notCharIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.notCharIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs + Pattern_many -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p + Pattern_many_corrected -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p + Pattern_capture -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p + Pattern_captureAs -> mkForeign $ + \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p + Pattern_join -> mkForeign $ \ps -> + evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps + Pattern_or -> mkForeign $ + \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r + Pattern_replicate -> mkForeign $ + \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> + let m = fromIntegral m0; n = fromIntegral n0 + in evaluate . TPat.cpattern $ TPat.Replicate m n p + Pattern_run -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input + Pattern_isMatch -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input + Char_Class_any -> mkForeign $ \() -> pure TPat.Any + Char_Class_not -> mkForeign $ pure . TPat.Not + Char_Class_and -> mkForeign $ \(a, b) -> pure $ TPat.Intersect a b + Char_Class_or -> mkForeign $ \(a, b) -> pure $ TPat.Union a b + Char_Class_range -> mkForeign $ \(a, b) -> pure $ TPat.CharRange a b + Char_Class_anyOf -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate $ TPat.CharSet cs + Char_Class_alphanumeric -> mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) + Char_Class_upper -> mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) + Char_Class_lower -> mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) + Char_Class_whitespace -> mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) + Char_Class_control -> mkForeign $ \() -> pure (TPat.CharClass TPat.Control) + Char_Class_printable -> mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) + Char_Class_mark -> mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) + Char_Class_number -> mkForeign $ \() -> pure (TPat.CharClass TPat.Number) + Char_Class_punctuation -> mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) + Char_Class_symbol -> mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) + Char_Class_separator -> mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) + Char_Class_letter -> mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) + Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c + Text_patterns_char -> mkForeign $ \c -> + let v = TPat.cpattern (TPat.Char c) in pure v where chop = reverse . dropWhile isPathSeparator . reverse @@ -606,6 +866,18 @@ foreignCall = \case exitDecode ExitSuccess = 0 exitDecode (ExitFailure n) = n + + mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack + mkHashAlgorithm txt alg = + let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) + in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) + + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Util.Text.pack (show se)) + Right a -> Right a {-# INLINE foreignCall #-} mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack @@ -634,7 +906,7 @@ mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) tryIOE :: IO a -> IO (Either (F.Failure Val) a) tryIOE = fmap handleIOE . UnliftIO.try handleIOE :: Either IOException a -> Either (F.Failure Val) a - handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue handleIOE (Right a) = Right a {-# INLINE mkForeignIOF #-} @@ -652,28 +924,371 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) tryIO2 = UnliftIO.try flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right a)) = Right a mkForeignTlsE :: forall a r. (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either (F.Failure Val) r)) -> + (a -> IO (Either Failure r)) -> Args -> Stack -> IO Stack mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) where - tryIO1 :: IO (Either (F.Failure Val) r) -> IO (Either TLS.TLSException (Either (F.Failure Val) r)) + tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) tryIO1 = UnliftIO.try - tryIO2 :: IO (Either TLS.TLSException (Either (F.Failure Val) r)) -> IO (Either IOException (Either TLS.TLSException (Either (F.Failure Val) r))) + tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) tryIO2 = UnliftIO.try - flatten :: Either IOException (Either TLS.TLSException (Either (F.Failure Val) r)) -> Either (F.Failure Val) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) flatten (Right (Right (Left e))) = Left e flatten (Right (Right (Right a))) = Right a unsafeSTMToIO :: STM.STM a -> IO a unsafeSTMToIO (STM.STM m) = IO m + +signEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signEd25519Wrapper (secret0, public0, msg0) = case validated of + CryptoFailed err -> + Left (F.Failure Ty.cryptoFailureRef (errMsg err) unitValue) + CryptoPassed (secret, public) -> + Right . Bytes.fromArray $ Ed25519.sign secret public msg + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) + <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +verifyEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyEd25519Wrapper (public0, msg0, sig0) = case validated of + CryptoFailed err -> + Left $ F.Failure Ty.cryptoFailureRef (errMsg err) unitValue + CryptoPassed (public, sig) -> + Right $ Ed25519.verify public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +signRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signRsaWrapper (secret0, msg0) = case validated of + Left err -> + Left (F.Failure Ty.cryptoFailureRef err unitValue) + Right secret -> + case RSA.sign Nothing (Just Hash.SHA256) secret msg of + Left err -> Left (F.Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) + Right signature -> Right $ Bytes.fromByteString signature + where + msg = Bytes.toArray msg0 :: ByteString + validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) + +verifyRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyRsaWrapper (public0, msg0, sig0) = case validated of + Left err -> + Left $ F.Failure Ty.cryptoFailureRef err unitValue + Right public -> + Right $ RSA.verify (Just Hash.SHA256) public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + sig = Bytes.toArray sig0 :: ByteString + validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) + +type Failure = F.Failure Val + +checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBounds name l w act + | w < fromIntegral l = act + | otherwise = pure $ Left err + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue w) + +-- Performs a bounds check on a byte array. Strategy is as follows: +-- +-- isz = signed array size-in-bytes +-- off = unsigned byte offset into the array +-- esz = unsigned number of bytes to be read +-- +-- 1. Turn the signed size-in-bytes of the array unsigned +-- 2. Add the offset to the to-be-read number to get the maximum size needed +-- 3. Check that the actual array size is at least as big as the needed size +-- 4. Check that the offset is less than the size +-- +-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can +-- only be 63 bits (since it is signed), the only way for 3 to overflow is if +-- the offset is larger than a possible array size, since it would need to be +-- 2^64-k, where k is the small (<=8) number of bytes to be read. +checkBoundsPrim :: + Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz off esz act + | w > bsz || off > bsz = pure $ Left err + | otherwise = act + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue off) + + bsz = fromIntegral isz + w = off + esz + +type RW = PA.PrimState IO + +checkedRead :: + Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) +checkedRead name (arr, w) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.readArray arr (fromIntegral w)) + +checkedWrite :: + Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) +checkedWrite name (arr, w, v) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.writeArray arr (fromIntegral w) v) + +checkedIndex :: + Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) +checkedIndex name (arr, w) = + checkBounds + name + (PA.sizeofArray arr) + w + (Right <$> PA.indexArrayM arr (fromIntegral w)) + +checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead8 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ + (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j + where + j = fromIntegral i + +checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead16 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ + mk16 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead24 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ + mk24 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + where + j = fromIntegral i + +checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead32 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ + mk32 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + where + j = fromIntegral i + +checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead40 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ + mk40 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + where + j = fromIntegral i + +checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead64 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ + mk64 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + <*> PA.readByteArray @Word8 arr (j + 5) + <*> PA.readByteArray @Word8 arr (j + 6) + <*> PA.readByteArray @Word8 arr (j + 7) + where + j = fromIntegral i + +mk16 :: Word8 -> Word8 -> Either Failure Word64 +mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) + +mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk24 b0 b1 b2 = + Right $ + (fromIntegral b0 `shiftL` 16) + .|. (fromIntegral b1 `shiftL` 8) + .|. (fromIntegral b2) + +mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk32 b0 b1 b2 b3 = + Right $ + (fromIntegral b0 `shiftL` 24) + .|. (fromIntegral b1 `shiftL` 16) + .|. (fromIntegral b2 `shiftL` 8) + .|. (fromIntegral b3) + +mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk40 b0 b1 b2 b3 b4 = + Right $ + (fromIntegral b0 `shiftL` 32) + .|. (fromIntegral b1 `shiftL` 24) + .|. (fromIntegral b2 `shiftL` 16) + .|. (fromIntegral b3 `shiftL` 8) + .|. (fromIntegral b4) + +mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk64 b0 b1 b2 b3 b4 b5 b6 b7 = + Right $ + (fromIntegral b0 `shiftL` 56) + .|. (fromIntegral b1 `shiftL` 48) + .|. (fromIntegral b2 `shiftL` 40) + .|. (fromIntegral b3 `shiftL` 32) + .|. (fromIntegral b4 `shiftL` 24) + .|. (fromIntegral b5 `shiftL` 16) + .|. (fromIntegral b6 `shiftL` 8) + .|. (fromIntegral b7) + +checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite8 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do + PA.writeByteArray arr j (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite16 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite32 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite64 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) + PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +-- index single byte +checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex8 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ + let j = fromIntegral i + in Right . fromIntegral $ PA.indexByteArray @Word8 arr j + +-- index 16 big-endian +checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex16 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ + let j = fromIntegral i + in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) + +-- index 32 big-endian +checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex24 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ + let j = fromIntegral i + in mk24 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + +-- index 32 big-endian +checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex32 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ + let j = fromIntegral i + in mk32 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + +-- index 40 big-endian +checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex40 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ + let j = fromIntegral i + in mk40 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + +-- index 64 big-endian +checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex64 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ + let j = fromIntegral i + in mk64 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + (PA.indexByteArray arr (j + 5)) + (PA.indexByteArray arr (j + 6)) + (PA.indexByteArray arr (j + 7)) From 12dbac8f26c6448bd087458638b5032cccfb592c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 4 Dec 2024 22:56:36 -0800 Subject: [PATCH 4/6] WIP on switching from numbered foreign funcs --- unison-runtime/src/Unison/Runtime/ANF.hs | 261 +++- .../src/Unison/Runtime/ANF/Serialize.hs | 18 +- unison-runtime/src/Unison/Runtime/Builtin.hs | 1273 ++++------------- .../src/Unison/Runtime/Foreign/Function.hs | 36 +- .../src/Unison/Runtime/Foreign/Impl.hs | 56 +- unison-runtime/src/Unison/Runtime/MCode.hs | 267 +++- unison-runtime/src/Unison/Runtime/Machine.hs | 21 +- 7 files changed, 840 insertions(+), 1092 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index 259987f07c..b2350e5bf0 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -42,7 +42,7 @@ module Unison.Runtime.ANF SuperGroup (..), arities, POp (..), - FOp, + ForeignFunc(..), close, saturate, float, @@ -1030,12 +1030,12 @@ pattern TPrm :: ABTN.Term ANormalF v pattern TPrm p args = TApp (FPrim (Left p)) args -pattern AFOp :: FOp -> [v] -> ANormalF v e +pattern AFOp :: ForeignFunc -> [v] -> ANormalF v e pattern AFOp p args = AApp (FPrim (Right p)) args pattern TFOp :: (ABT.Var v) => - FOp -> + ForeignFunc -> [v] -> ABTN.Term ANormalF v pattern TFOp p args = TApp (FPrim (Right p)) args @@ -1232,9 +1232,6 @@ instance Semigroup (BranchAccum v) where instance Monoid (BranchAccum e) where mempty = AccumEmpty --- Foreign operation, indexed by words -type FOp = Word64 - data Func v = -- variable FVar v @@ -1247,7 +1244,7 @@ data Func v | -- ability request FReq !Reference !CTag | -- prim op - FPrim (Either POp FOp) + FPrim (Either POp ForeignFunc) deriving (Show, Eq, Functor, Foldable, Traversable) data Lit @@ -1439,6 +1436,256 @@ data POp | IORB -- or deriving (Show, Eq, Ord, Enum, Bounded) +-- | Enum representing every foreign call. +data ForeignFunc + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + type ANormal = ABTN.Term ANormalF type Cte v = CTE v (ANormal v) diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 9b6c575232..fd223aba71 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -317,7 +317,7 @@ putGroup :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> SuperGroup v -> m () putGroup refrep fops (Rec bs e) = @@ -338,7 +338,7 @@ getGroup = do cs <- replicateM l (getComb ctx n) Rec (zip vs cs) <$> getComb ctx n -putCode :: (MonadPut m) => EC.EnumMap FOp Text -> Code -> m () +putCode :: (MonadPut m) => EC.EnumMap ForeignFunc Text -> Code -> m () putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c getCode :: (MonadGet m) => Word32 -> m Code @@ -363,7 +363,7 @@ putComb :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> SuperNormal v -> m () @@ -384,7 +384,7 @@ putNormal :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> ANormal v -> m () @@ -482,7 +482,7 @@ putFunc :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> Func v -> m () @@ -757,7 +757,7 @@ putBranches :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> Branched (ANormal v) -> m () @@ -825,7 +825,7 @@ putCase :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> [v] -> ([Mem], ANormal v) -> m () @@ -997,7 +997,7 @@ deserializeCode bs = runGetS (getVersion >>= getCode) bs n | 1 <= n && n <= 3 -> pure n n -> fail $ "deserializeGroup: unknown version: " ++ show n -serializeCode :: EC.EnumMap FOp Text -> Code -> ByteString +serializeCode :: EC.EnumMap ForeignFunc Text -> Code -> ByteString serializeCode fops co = runPutS (putVersion *> putCode fops co) where putVersion = putWord32be codeVersion @@ -1023,7 +1023,7 @@ serializeCode fops co = runPutS (putVersion *> putCode fops co) -- shouldn't be subject to rehashing. serializeGroupForRehash :: (Var v) => - EC.EnumMap FOp Text -> + EC.EnumMap ForeignFunc Text -> Reference -> SuperGroup v -> L.ByteString diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 1a65902dd9..6ef8783946 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -8,8 +8,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Unison.Runtime.Builtin - ( builtinLookup, - builtinTermNumbering, + ( builtinTermNumbering, builtinTypeNumbering, builtinTermBackref, builtinTypeBackref, @@ -26,171 +25,31 @@ module Unison.Runtime.Builtin ) where -import Control.Concurrent (ThreadId) -import Control.Concurrent as SYS - ( killThread, - threadDelay, - ) -import Control.Concurrent.MVar as SYS import Control.Concurrent.STM qualified as STM -import Control.DeepSeq (NFData) -import Control.Exception (evaluate) -import Control.Exception.Safe qualified as Exception -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Primitive qualified as PA import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Control.Monad.State.Strict (State, execState, modify) -import Crypto.Error (CryptoError (..), CryptoFailable (..)) -import Crypto.Hash qualified as Hash -import Crypto.MAC.HMAC qualified as HMAC -import Crypto.PubKey.Ed25519 qualified as Ed25519 -import Crypto.PubKey.RSA.PKCS15 qualified as RSA -import Crypto.Random (getRandomBytes) -import Data.Bits (shiftL, shiftR, (.|.)) -import Data.ByteArray qualified as BA -import Data.ByteString (hGet, hGetSome, hPut) -import Data.ByteString.Lazy qualified as L -import Data.Default (def) -import Data.Digest.Murmur64 (asWord64, hash64) -import Data.IP (IP) import Data.Map qualified as Map -import Data.PEM (PEM, pemContent, pemParseLBS) import Data.Set (insert) import Data.Set qualified as Set import Data.Text qualified -import Data.Text.IO qualified as Text.IO -import Data.Time.Clock.POSIX as SYS - ( getPOSIXTime, - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.LocalTime (TimeZone (..), getTimeZone) -import Data.X509 qualified as X -import Data.X509.CertificateStore qualified as X -import Data.X509.Memory qualified as X import GHC.Conc qualified as STM import GHC.IO (IO (IO)) -import Network.Simple.TCP as SYS - ( HostPreference (..), - bindSock, - closeSock, - connectSock, - listenSock, - recv, - send, - ) -import Network.Socket as SYS - ( PortNumber, - Socket, - accept, - socketPort, - ) -import Network.TLS as TLS -import Network.TLS.Extra.Cipher as Cipher -import Network.UDP as UDP - ( ClientSockAddr, - ListenSocket, - UDPSocket (..), - clientSocket, - close, - recv, - recvFrom, - send, - sendTo, - serverSocket, - stop, - ) -import System.Clock (Clock (..), getTime, nsec, sec) -import System.Directory as SYS - ( createDirectoryIfMissing, - doesDirectoryExist, - doesPathExist, - getCurrentDirectory, - getDirectoryContents, - getFileSize, - getModificationTime, - getTemporaryDirectory, - removeDirectoryRecursive, - removeFile, - renameDirectory, - renameFile, - setCurrentDirectory, - ) -import System.Environment as SYS - ( getArgs, - getEnv, - ) -import System.Exit as SYS (ExitCode (..)) -import System.FilePath (isPathSeparator) -import System.IO (Handle) -import System.IO as SYS - ( IOMode (..), - hClose, - hGetBuffering, - hGetChar, - hGetEcho, - hIsEOF, - hIsOpen, - hIsSeekable, - hReady, - hSeek, - hSetBuffering, - hSetEcho, - hTell, - openFile, - stderr, - stdin, - stdout, - ) -import System.IO.Temp (createTempDirectory) -import System.Process as SYS - ( getProcessExitCode, - proc, - runInteractiveProcess, - terminateProcess, - waitForProcess, - withCreateProcess, - ) -import System.X509 qualified as X import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference -import Unison.Referent (Referent, pattern Ref) import Unison.Runtime.ANF as ANF -import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize as ANF -import Unison.Runtime.Array qualified as PA import Unison.Runtime.Builtin.Types -import Unison.Runtime.Crypto.Rsa as Rsa import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign - ( Foreign (Wrap), - HashAlgorithm (..), - pattern Failure, - ) import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function -import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol import Unison.Type qualified as Ty -import Unison.Util.Bytes qualified as Bytes import Unison.Util.EnumContainers as EC -import Unison.Util.RefPromise - ( Promise, - newPromise, - readPromise, - tryReadPromise, - writePromise, - ) -import Unison.Util.Text (Text) import Unison.Util.Text qualified as Util.Text -import Unison.Util.Text.Pattern qualified as TPat import Unison.Var -type Failure = F.Failure Val - freshes :: (Var v) => Int -> [v] freshes = freshes' mempty @@ -890,7 +749,7 @@ stm'atomic = where (act, unit, lz) = fresh -type ForeignOp = FOp -> ([Mem], ANormal Symbol) +type ForeignOp = ForeignFunc -> ([Mem], ANormal Symbol) standard'handle :: ForeignOp standard'handle instr = @@ -1119,30 +978,30 @@ crypto'hmac instr = -- -- () -> ... -inUnit :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inUnit :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inUnit unit result cont instr = ([BX], TAbs unit $ TLetD result UN (TFOp instr []) cont) -inN :: forall v. (Var v) => [v] -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inN :: forall v. (Var v) => [v] -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inN args result cont instr = (args $> BX,) . TAbss args $ TLetD result UN (TFOp instr args) cont -- a -> ... -in1 :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in1 :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) in1 arg result cont instr = inN [arg] result cont instr -- a -> b -> ... -in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) in2 arg1 arg2 result cont instr = inN [arg1, arg2] result cont instr -- a -> b -> c -> ... -in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) in3 arg1 arg2 arg3 result cont instr = inN [arg1, arg2, arg3] result cont instr -- Maybe a -> b -> ... -inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inMaybeBx arg1 arg2 arg3 mb result cont instr = ([BX, BX],) . TAbss [arg1, arg2] @@ -1169,7 +1028,7 @@ set'echo instr = (arg1, arg2, bol, stack1, stack2, stack3, unit, fail, result) = fresh -- a -> IOMode -> ... -inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inIomr arg1 arg2 fm result cont instr = ([BX, BX],) . TAbss [arg1, arg2] @@ -1838,10 +1697,7 @@ builtinLookup = ++ foreignWrappers type FDecl v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) - -type FDecl' v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc'))) + ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], Map Word64 (Data.Text.Text, ForeignFunc))) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1850,255 +1706,6 @@ type FDecl' v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) -foreignFuncTracking :: ForeignFunc' -> Sandbox -foreignFuncTracking = \case - IO_UDP_clientSocket_impl_v1 -> Tracked - IO_UDP_UDPSocket_recv_impl_v1 -> Tracked - IO_UDP_UDPSocket_send_impl_v1 -> Tracked - IO_UDP_UDPSocket_close_impl_v1 -> Tracked - IO_UDP_ListenSocket_close_impl_v1 -> Tracked - IO_UDP_UDPSocket_toText_impl_v1 -> Tracked - IO_UDP_serverSocket_impl_v1 -> Tracked - IO_UDP_ListenSocket_toText_impl_v1 -> Tracked - IO_UDP_ListenSocket_recvFrom_impl_v1 -> Tracked - IO_UDP_ClientSockAddr_toText_v1 -> Tracked - IO_UDP_ListenSocket_sendTo_impl_v1 -> Tracked - IO_openFile_impl_v3 -> Tracked - IO_closeFile_impl_v3 -> Tracked - IO_isFileEOF_impl_v3 -> Tracked - IO_isFileOpen_impl_v3 -> Tracked - IO_getEcho_impl_v1 -> Tracked - IO_ready_impl_v1 -> Tracked - IO_getChar_impl_v1 -> Tracked - IO_isSeekable_impl_v3 -> Tracked - IO_seekHandle_impl_v3 -> Tracked - IO_handlePosition_impl_v3 -> Tracked - IO_getBuffering_impl_v3 -> Tracked - IO_setBuffering_impl_v3 -> Tracked - IO_setEcho_impl_v1 -> Tracked - IO_getLine_impl_v1 -> Tracked - IO_getBytes_impl_v3 -> Tracked - IO_getSomeBytes_impl_v1 -> Tracked - IO_putBytes_impl_v3 -> Tracked - IO_systemTime_impl_v3 -> Tracked - IO_systemTimeMicroseconds_v1 -> Tracked - Clock_internals_monotonic_v1 -> Tracked - Clock_internals_realtime_v1 -> Tracked - Clock_internals_processCPUTime_v1 -> Tracked - Clock_internals_threadCPUTime_v1 -> Tracked - Clock_internals_sec_v1 -> Tracked - Clock_internals_nsec_v1 -> Tracked - Clock_internals_systemTimeZone_v1 -> Tracked - IO_getTempDirectory_impl_v3 -> Tracked - IO_createTempDirectory_impl_v3 -> Tracked - IO_getCurrentDirectory_impl_v3 -> Tracked - IO_setCurrentDirectory_impl_v3 -> Tracked - IO_fileExists_impl_v3 -> Tracked - IO_getEnv_impl_v1 -> Tracked - IO_getArgs_impl_v1 -> Tracked - IO_isDirectory_impl_v3 -> Tracked - IO_createDirectory_impl_v3 -> Tracked - IO_removeDirectory_impl_v3 -> Tracked - IO_renameDirectory_impl_v3 -> Tracked - IO_directoryContents_impl_v3 -> Tracked - IO_removeFile_impl_v3 -> Tracked - IO_renameFile_impl_v3 -> Tracked - IO_getFileTimestamp_impl_v3 -> Tracked - IO_getFileSize_impl_v3 -> Tracked - IO_serverSocket_impl_v3 -> Tracked - Socket_toText -> Tracked - Handle_toText -> Tracked - ThreadId_toText -> Tracked - IO_socketPort_impl_v3 -> Tracked - IO_listen_impl_v3 -> Tracked - IO_clientSocket_impl_v3 -> Tracked - IO_closeSocket_impl_v3 -> Tracked - IO_socketAccept_impl_v3 -> Tracked - IO_socketSend_impl_v3 -> Tracked - IO_socketReceive_impl_v3 -> Tracked - IO_kill_impl_v3 -> Tracked - IO_delay_impl_v3 -> Tracked - IO_stdHandle -> Tracked - IO_process_call -> Tracked - IO_process_start -> Tracked - IO_process_kill -> Tracked - IO_process_wait -> Tracked - IO_process_exitCode -> Tracked - MVar_new -> Tracked - MVar_newEmpty_v2 -> Tracked - MVar_take_impl_v3 -> Tracked - MVar_tryTake -> Tracked - MVar_put_impl_v3 -> Tracked - MVar_tryPut_impl_v3 -> Tracked - MVar_swap_impl_v3 -> Tracked - MVar_isEmpty -> Tracked - MVar_read_impl_v3 -> Tracked - MVar_tryRead_impl_v3 -> Tracked - Char_toText -> Untracked - Text_repeat -> Untracked - Text_reverse -> Untracked - Text_toUppercase -> Untracked - Text_toLowercase -> Untracked - Text_toUtf8 -> Untracked - Text_fromUtf8_impl_v3 -> Untracked - Tls_ClientConfig_default -> Tracked - Tls_ServerConfig_default -> Tracked - Tls_ClientConfig_certificates_set -> Tracked - Tls_ServerConfig_certificates_set -> Tracked - TVar_new -> Tracked - TVar_read -> Tracked - TVar_write -> Tracked - TVar_newIO -> Tracked - TVar_readIO -> Tracked - TVar_swap -> Tracked - STM_retry -> Tracked - Promise_new -> Tracked - Promise_read -> Tracked - Promise_tryRead -> Tracked - Promise_write -> Tracked - Tls_newClient_impl_v3 -> Tracked - Tls_newServer_impl_v3 -> Tracked - Tls_handshake_impl_v3 -> Tracked - Tls_send_impl_v3 -> Tracked - Tls_decodeCert_impl_v3 -> Tracked - Tls_encodeCert -> Tracked - Tls_decodePrivateKey -> Tracked - Tls_encodePrivateKey -> Tracked - Tls_receive_impl_v3 -> Tracked - Tls_terminate_impl_v3 -> Tracked - Code_validateLinks -> Untracked - Code_dependencies -> Untracked - Code_serialize -> Untracked - Code_deserialize -> Untracked - Code_display -> Untracked - Value_dependencies -> Untracked - Value_serialize -> Untracked - Value_deserialize -> Untracked - Crypto_HashAlgorithm_Sha3_512 -> Untracked - Crypto_HashAlgorithm_Sha3_256 -> Untracked - Crypto_HashAlgorithm_Sha2_512 -> Untracked - Crypto_HashAlgorithm_Sha2_256 -> Untracked - Crypto_HashAlgorithm_Sha1 -> Untracked - Crypto_HashAlgorithm_Blake2b_512 -> Untracked - Crypto_HashAlgorithm_Blake2b_256 -> Untracked - Crypto_HashAlgorithm_Blake2s_256 -> Untracked - Crypto_HashAlgorithm_Md5 -> Untracked - Crypto_hashBytes -> Untracked - Crypto_hmacBytes -> Untracked - Crypto_hash -> Untracked - Crypto_hmac -> Untracked - Crypto_Ed25519_sign_impl -> Untracked - Crypto_Ed25519_verify_impl -> Untracked - Crypto_Rsa_sign_impl -> Untracked - Crypto_Rsa_verify_impl -> Untracked - Universal_murmurHash -> Untracked - IO_randomBytes -> Tracked - Bytes_zlib_compress -> Untracked - Bytes_gzip_compress -> Untracked - Bytes_zlib_decompress -> Untracked - Bytes_gzip_decompress -> Untracked - Bytes_toBase16 -> Untracked - Bytes_toBase32 -> Untracked - Bytes_toBase64 -> Untracked - Bytes_toBase64UrlUnpadded -> Untracked - Bytes_fromBase16 -> Untracked - Bytes_fromBase32 -> Untracked - Bytes_fromBase64 -> Untracked - Bytes_fromBase64UrlUnpadded -> Untracked - Bytes_decodeNat64be -> Untracked - Bytes_decodeNat64le -> Untracked - Bytes_decodeNat32be -> Untracked - Bytes_decodeNat32le -> Untracked - Bytes_decodeNat16be -> Untracked - Bytes_decodeNat16le -> Untracked - Bytes_encodeNat64be -> Untracked - Bytes_encodeNat64le -> Untracked - Bytes_encodeNat32be -> Untracked - Bytes_encodeNat32le -> Untracked - Bytes_encodeNat16be -> Untracked - Bytes_encodeNat16le -> Untracked - MutableArray_copyTo_force -> Untracked - MutableByteArray_copyTo_force -> Untracked - ImmutableArray_copyTo_force -> Untracked - ImmutableArray_size -> Untracked - MutableArray_size -> Untracked - ImmutableByteArray_size -> Untracked - MutableByteArray_size -> Untracked - ImmutableByteArray_copyTo_force -> Untracked - MutableArray_read -> Untracked - MutableByteArray_read8 -> Untracked - MutableByteArray_read16be -> Untracked - MutableByteArray_read24be -> Untracked - MutableByteArray_read32be -> Untracked - MutableByteArray_read40be -> Untracked - MutableByteArray_read64be -> Untracked - MutableArray_write -> Untracked - MutableByteArray_write8 -> Untracked - MutableByteArray_write16be -> Untracked - MutableByteArray_write32be -> Untracked - MutableByteArray_write64be -> Untracked - ImmutableArray_read -> Untracked - ImmutableByteArray_read8 -> Untracked - ImmutableByteArray_read16be -> Untracked - ImmutableByteArray_read24be -> Untracked - ImmutableByteArray_read32be -> Untracked - ImmutableByteArray_read40be -> Untracked - ImmutableByteArray_read64be -> Untracked - MutableByteArray_freeze_force -> Untracked - MutableArray_freeze_force -> Untracked - MutableByteArray_freeze -> Untracked - MutableArray_freeze -> Untracked - MutableByteArray_length -> Untracked - ImmutableByteArray_length -> Untracked - IO_array -> Tracked - IO_arrayOf -> Tracked - IO_bytearray -> Tracked - IO_bytearrayOf -> Tracked - Scope_array -> Untracked - Scope_arrayOf -> Untracked - Scope_bytearray -> Untracked - Scope_bytearrayOf -> Untracked - Text_patterns_literal -> Untracked - Text_patterns_digit -> Untracked - Text_patterns_letter -> Untracked - Text_patterns_space -> Untracked - Text_patterns_punctuation -> Untracked - Text_patterns_anyChar -> Untracked - Text_patterns_eof -> Untracked - Text_patterns_charRange -> Untracked - Text_patterns_notCharRange -> Untracked - Text_patterns_charIn -> Untracked - Text_patterns_notCharIn -> Untracked - Pattern_many -> Untracked - Pattern_many_corrected -> Untracked - Pattern_capture -> Untracked - Pattern_captureAs -> Untracked - Pattern_join -> Untracked - Pattern_or -> Untracked - Pattern_replicate -> Untracked - Pattern_run -> Untracked - Pattern_isMatch -> Untracked - Char_Class_any -> Untracked - Char_Class_not -> Untracked - Char_Class_and -> Untracked - Char_Class_or -> Untracked - Char_Class_range -> Untracked - Char_Class_anyOf -> Untracked - Char_Class_alphanumeric -> Untracked - Char_Class_upper -> Untracked - Char_Class_lower -> Untracked - Char_Class_whitespace -> Untracked - Char_Class_control -> Untracked - Char_Class_printable -> Untracked - Char_Class_mark -> Untracked - Char_Class_number -> Untracked - Char_Class_punctuation -> Untracked - Char_Class_symbol -> Untracked - Char_Class_separator -> Untracked - Char_Class_letter -> Untracked - Char_Class_is -> Untracked - Text_patterns_char -> Untracked - bomb :: Data.Text.Text -> a -> IO r bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name @@ -2109,24 +1716,6 @@ declareForeign :: ForeignFunc -> FDecl Symbol () declareForeign sand name op func0 = do - sanitize <- ask - modify $ \(w, codes, funcs) -> - let func - | sanitize, - Tracked <- sand, - FF r w _ <- func0 = - FF r w (bomb name) - | otherwise = func0 - code = (name, (sand, uncurry Lambda (op w))) - in (w + 1, code : codes, mapInsert w (name, func) funcs) - -declareForeign' :: - Sandbox -> - Data.Text.Text -> - ForeignOp -> - ForeignFunc' -> - FDecl' Symbol () -declareForeign' sand name op func0 = do sanitize <- ask modify $ \(w, codes, funcs) -> let func @@ -2143,641 +1732,369 @@ unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) natValue :: Word64 -> Val natValue w = NatVal w -declareUdpForeigns :: FDecl' Symbol () +declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign' Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 + declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign' Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 + declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign' Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 + declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign' Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 + declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign' Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 + declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 -declareForeigns :: FDecl' Symbol () +declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign' Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 + declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 - declareForeign' Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 - declareForeign' Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 - declareForeign' Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 - declareForeign' Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 - declareForeign' Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 - declareForeign' Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 - declareForeign' Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 + declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 + declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 + declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 + declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 + declareForeign Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 + declareForeign Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 + declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 - declareForeign' Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 + declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 - declareForeign' Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 + declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 - declareForeign' Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 + declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 - declareForeign' Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 + declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 - declareForeign' Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 + declareForeign Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 - declareForeign' Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 + declareForeign Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 - declareForeign' Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 - declareForeign' Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 - declareForeign' Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 - declareForeign' Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 + declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 + declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 + declareForeign Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 - declareForeign' Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 + declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 - declareForeign' Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 + declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 - declareForeign' Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 + declareForeign Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 - declareForeign' Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 + declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 - declareForeign' Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 + declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 - declareForeign' Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 + declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 -- A TimeSpec that comes from getTime never has negative nanos, -- so we can safely cast to Nat - declareForeign' Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 + declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 - declareForeign' Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 + declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 - declareForeign' Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 + declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 - declareForeign' Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 + declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 - declareForeign' Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 + declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign' Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 + declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign' Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 + declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 - declareForeign' Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 + declareForeign Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 - declareForeign' Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 + declareForeign Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 - declareForeign' Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 + declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 - declareForeign' Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 + declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 - declareForeign' Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 + declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 - declareForeign' Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 + declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 - declareForeign' Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 + declareForeign Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 - declareForeign' Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 + declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 - declareForeign' Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 + declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 - declareForeign' Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 + declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 - declareForeign' Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 + declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 - declareForeign' Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 + declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 - declareForeign' Tracked "Socket.toText" (argNDirect 1) Socket_toText + declareForeign Tracked "Socket.toText" (argNDirect 1) Socket_toText - declareForeign' Tracked "Handle.toText" (argNDirect 1) Handle_toText + declareForeign Tracked "Handle.toText" (argNDirect 1) Handle_toText - declareForeign' Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText + declareForeign Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText - declareForeign' Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 + declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 - declareForeign' Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 + declareForeign Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 - declareForeign' Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 + declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 - declareForeign' Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 + declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 - declareForeign' Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 + declareForeign Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 - declareForeign' Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 + declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 - declareForeign' Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 + declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 - declareForeign' Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 + declareForeign Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 - declareForeign' Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 + declareForeign Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 - declareForeign' Tracked "IO.stdHandle" standard'handle IO_stdHandle + declareForeign Tracked "IO.stdHandle" standard'handle IO_stdHandle - declareForeign' Tracked "IO.process.call" (argNDirect 2) IO_process_call + declareForeign Tracked "IO.process.call" (argNDirect 2) IO_process_call - declareForeign' Tracked "IO.process.start" start'process IO_process_start + declareForeign Tracked "IO.process.start" start'process IO_process_start - declareForeign' Tracked "IO.process.kill" argToUnit IO_process_kill + declareForeign Tracked "IO.process.kill" argToUnit IO_process_kill - declareForeign' Tracked "IO.process.wait" (argNDirect 1) IO_process_wait + declareForeign Tracked "IO.process.wait" (argNDirect 1) IO_process_wait - declareForeign' Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode - declareForeign' Tracked "MVar.new" (argNDirect 1) MVar_new + declareForeign Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode + declareForeign Tracked "MVar.new" (argNDirect 1) MVar_new - declareForeign' Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 + declareForeign Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 - declareForeign' Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 + declareForeign Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 - declareForeign' Tracked "MVar.tryTake" argToMaybe MVar_tryTake + declareForeign Tracked "MVar.tryTake" argToMaybe MVar_tryTake - declareForeign' Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 + declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 - declareForeign' Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 + declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign' Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 + declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 - declareForeign' Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty + declareForeign Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty - declareForeign' Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 + declareForeign Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 - declareForeign' Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 + declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 - declareForeign' Untracked "Char.toText" (argNDirect 1) Char_toText - declareForeign' Untracked "Text.repeat" (argNDirect 2) Text_repeat - declareForeign' Untracked "Text.reverse" (argNDirect 1) Text_reverse - declareForeign' Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase - declareForeign' Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase - declareForeign' Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 - declareForeign' Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 - declareForeign' Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default - declareForeign' Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default - declareForeign' Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set + declareForeign Untracked "Char.toText" (argNDirect 1) Char_toText + declareForeign Untracked "Text.repeat" (argNDirect 2) Text_repeat + declareForeign Untracked "Text.reverse" (argNDirect 1) Text_reverse + declareForeign Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase + declareForeign Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase + declareForeign Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 + declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 + declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default + declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default + declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set - declareForeign' Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set + declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign' Tracked "TVar.new" (argNDirect 1) TVar_new + declareForeign Tracked "TVar.new" (argNDirect 1) TVar_new - declareForeign' Tracked "TVar.read" (argNDirect 1) TVar_read - declareForeign' Tracked "TVar.write" arg2To0 TVar_write - declareForeign' Tracked "TVar.newIO" (argNDirect 1) TVar_newIO + declareForeign Tracked "TVar.read" (argNDirect 1) TVar_read + declareForeign Tracked "TVar.write" arg2To0 TVar_write + declareForeign Tracked "TVar.newIO" (argNDirect 1) TVar_newIO - declareForeign' Tracked "TVar.readIO" (argNDirect 1) TVar_readIO - declareForeign' Tracked "TVar.swap" (argNDirect 2) TVar_swap - declareForeign' Tracked "STM.retry" unitDirect STM_retry - declareForeign' Tracked "Promise.new" unitDirect Promise_new + declareForeign Tracked "TVar.readIO" (argNDirect 1) TVar_readIO + declareForeign Tracked "TVar.swap" (argNDirect 2) TVar_swap + declareForeign Tracked "STM.retry" unitDirect STM_retry + declareForeign Tracked "Promise.new" unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign' Tracked "Promise.read" (argNDirect 1) Promise_read - declareForeign' Tracked "Promise.tryRead" argToMaybe Promise_tryRead - - declareForeign' Tracked "Promise.write" (argNDirect 2) Promise_write - declareForeign' Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 - declareForeign' Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 - declareForeign' Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 - declareForeign' Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 - declareForeign' Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 - - declareForeign' Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert - - declareForeign' Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey - declareForeign' Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey - - declareForeign' Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 - - declareForeign' Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 - declareForeign' Untracked "Code.validateLinks" argToExnE Code_validateLinks - declareForeign' Untracked "Code.dependencies" (argNDirect 1) Code_dependencies - declareForeign' Untracked "Code.serialize" (argNDirect 1) Code_serialize - declareForeign' Untracked "Code.deserialize" argToEither Code_deserialize - declareForeign' Untracked "Code.display" (argNDirect 2) Code_display - declareForeign' Untracked "Value.dependencies" (argNDirect 1) Value_dependencies - declareForeign' Untracked "Value.serialize" (argNDirect 1) Value_serialize - declareForeign' Untracked "Value.deserialize" argToEither Value_deserialize + declareForeign Tracked "Promise.read" (argNDirect 1) Promise_read + declareForeign Tracked "Promise.tryRead" argToMaybe Promise_tryRead + + declareForeign Tracked "Promise.write" (argNDirect 2) Promise_write + declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 + declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 + declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 + declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 + declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 + + declareForeign Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert + + declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey + declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey + + declareForeign Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 + + declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 + declareForeign Untracked "Code.validateLinks" argToExnE Code_validateLinks + declareForeign Untracked "Code.dependencies" (argNDirect 1) Code_dependencies + declareForeign Untracked "Code.serialize" (argNDirect 1) Code_serialize + declareForeign Untracked "Code.deserialize" argToEither Code_deserialize + declareForeign Untracked "Code.display" (argNDirect 2) Code_display + declareForeign Untracked "Value.dependencies" (argNDirect 1) Value_dependencies + declareForeign Untracked "Value.serialize" (argNDirect 1) Value_serialize + declareForeign Untracked "Value.deserialize" argToEither Value_deserialize -- Hashing functions - declareForeign' Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 - declareForeign' Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 - declareForeign' Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 - declareForeign' Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 - declareForeign' Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 - declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 - declareForeign' Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 - declareForeign' Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 - declareForeign' Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 - - declareForeign' Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes - declareForeign' Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes - - declareForeign' Untracked "crypto.hash" crypto'hash Crypto_hash - declareForeign' Untracked "crypto.hmac" crypto'hmac Crypto_hmac - declareForeign' Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl - - declareForeign' Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl - - declareForeign' Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl - - declareForeign' Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl - - declareForeign' Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash - declareForeign' Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes - declareForeign' Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress - declareForeign' Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress - declareForeign' Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress - declareForeign' Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress - - declareForeign' Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 - declareForeign' Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 - declareForeign' Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 - declareForeign' Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded - - declareForeign' Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 - declareForeign' Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 - declareForeign' Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 - declareForeign' Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded - - declareForeign' Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be - declareForeign' Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le - declareForeign' Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be - declareForeign' Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le - declareForeign' Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be - declareForeign' Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le - - declareForeign' Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be - declareForeign' Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le - declareForeign' Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be - declareForeign' Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le - declareForeign' Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be - declareForeign' Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le - - declareForeign' Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force - - declareForeign' Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force - - declareForeign' Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force - - declareForeign' Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size - declareForeign' Untracked "MutableArray.size" (argNDirect 1) MutableArray_size - declareForeign' Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size - declareForeign' Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size - - declareForeign' Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force - - declareForeign' Untracked "MutableArray.read" arg2ToExn MutableArray_read - declareForeign' Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 - declareForeign' Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be - declareForeign' Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be - declareForeign' Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be - declareForeign' Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be - declareForeign' Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be - - declareForeign' Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write - declareForeign' Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 - declareForeign' Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be - declareForeign' Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be - declareForeign' Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be - - declareForeign' Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read - declareForeign' Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 - declareForeign' Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be - declareForeign' Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be - declareForeign' Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be - declareForeign' Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be - declareForeign' Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be - - declareForeign' Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force - declareForeign' Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force - - declareForeign' Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze - declareForeign' Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze - - declareForeign' Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length - - declareForeign' Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length - - declareForeign' Tracked "IO.array" (argNDirect 1) IO_array - declareForeign' Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf - declareForeign' Tracked "IO.bytearray" (argNDirect 1) IO_bytearray - declareForeign' Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf - - declareForeign' Untracked "Scope.array" (argNDirect 1) Scope_array - declareForeign' Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf - declareForeign' Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray - declareForeign' Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf - - declareForeign' Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal - declareForeign' Untracked "Text.patterns.digit" direct Text_patterns_digit - declareForeign' Untracked "Text.patterns.letter" direct Text_patterns_letter - declareForeign' Untracked "Text.patterns.space" direct Text_patterns_space - declareForeign' Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation - declareForeign' Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar - declareForeign' Untracked "Text.patterns.eof" direct Text_patterns_eof - declareForeign' Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange - declareForeign' Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange - declareForeign' Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn - declareForeign' Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn - declareForeign' Untracked "Pattern.many" (argNDirect 1) Pattern_many - declareForeign' Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected - declareForeign' Untracked "Pattern.capture" (argNDirect 1) Pattern_capture - declareForeign' Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs - declareForeign' Untracked "Pattern.join" (argNDirect 1) Pattern_join - declareForeign' Untracked "Pattern.or" (argNDirect 2) Pattern_or - declareForeign' Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate - - declareForeign' Untracked "Pattern.run" arg2ToMaybeTup Pattern_run - - declareForeign' Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch - - declareForeign' Untracked "Char.Class.any" direct Char_Class_any - declareForeign' Untracked "Char.Class.not" (argNDirect 1) Char_Class_not - declareForeign' Untracked "Char.Class.and" (argNDirect 2) Char_Class_and - declareForeign' Untracked "Char.Class.or" (argNDirect 2) Char_Class_or - declareForeign' Untracked "Char.Class.range" (argNDirect 2) Char_Class_range - declareForeign' Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf - declareForeign' Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric - declareForeign' Untracked "Char.Class.upper" direct Char_Class_upper - declareForeign' Untracked "Char.Class.lower" direct Char_Class_lower - declareForeign' Untracked "Char.Class.whitespace" direct Char_Class_whitespace - declareForeign' Untracked "Char.Class.control" direct Char_Class_control - declareForeign' Untracked "Char.Class.printable" direct Char_Class_printable - declareForeign' Untracked "Char.Class.mark" direct Char_Class_mark - declareForeign' Untracked "Char.Class.number" direct Char_Class_number - declareForeign' Untracked "Char.Class.punctuation" direct Char_Class_punctuation - declareForeign' Untracked "Char.Class.symbol" direct Char_Class_symbol - declareForeign' Untracked "Char.Class.separator" direct Char_Class_separator - declareForeign' Untracked "Char.Class.letter" direct Char_Class_letter - declareForeign' Untracked "Char.Class.is" (argNDirect 2) Char_Class_is - declareForeign' Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char - -type RW = PA.PrimState IO - -checkedRead :: - Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) -checkedRead name (arr, w) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.readArray arr (fromIntegral w)) - -checkedWrite :: - Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) -checkedWrite name (arr, w, v) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.writeArray arr (fromIntegral w) v) - -checkedIndex :: - Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) -checkedIndex name (arr, w) = - checkBounds - name - (PA.sizeofArray arr) - w - (Right <$> PA.indexArrayM arr (fromIntegral w)) - -checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead8 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ - (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j - where - j = fromIntegral i - -checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead16 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ - mk16 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - where - j = fromIntegral i - -checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead24 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ - mk24 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - where - j = fromIntegral i - -checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead32 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ - mk32 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - where - j = fromIntegral i - -checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead40 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ - mk40 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - where - j = fromIntegral i - -checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead64 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ - mk64 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - <*> PA.readByteArray @Word8 arr (j + 5) - <*> PA.readByteArray @Word8 arr (j + 6) - <*> PA.readByteArray @Word8 arr (j + 7) - where - j = fromIntegral i - -mk16 :: Word8 -> Word8 -> Either Failure Word64 -mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) - -mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk24 b0 b1 b2 = - Right $ - (fromIntegral b0 `shiftL` 16) - .|. (fromIntegral b1 `shiftL` 8) - .|. (fromIntegral b2) - -mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk32 b0 b1 b2 b3 = - Right $ - (fromIntegral b0 `shiftL` 24) - .|. (fromIntegral b1 `shiftL` 16) - .|. (fromIntegral b2 `shiftL` 8) - .|. (fromIntegral b3) - -mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk40 b0 b1 b2 b3 b4 = - Right $ - (fromIntegral b0 `shiftL` 32) - .|. (fromIntegral b1 `shiftL` 24) - .|. (fromIntegral b2 `shiftL` 16) - .|. (fromIntegral b3 `shiftL` 8) - .|. (fromIntegral b4) - -mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk64 b0 b1 b2 b3 b4 b5 b6 b7 = - Right $ - (fromIntegral b0 `shiftL` 56) - .|. (fromIntegral b1 `shiftL` 48) - .|. (fromIntegral b2 `shiftL` 40) - .|. (fromIntegral b3 `shiftL` 32) - .|. (fromIntegral b4 `shiftL` 24) - .|. (fromIntegral b5 `shiftL` 16) - .|. (fromIntegral b6 `shiftL` 8) - .|. (fromIntegral b7) - -checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite8 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do - PA.writeByteArray arr j (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite16 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite32 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite64 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) - PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - --- index single byte -checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex8 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ - let j = fromIntegral i - in Right . fromIntegral $ PA.indexByteArray @Word8 arr j - --- index 16 big-endian -checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex16 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ - let j = fromIntegral i - in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) - --- index 32 big-endian -checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex24 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ - let j = fromIntegral i - in mk24 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - --- index 32 big-endian -checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex32 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ - let j = fromIntegral i - in mk32 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - --- index 40 big-endian -checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex40 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ - let j = fromIntegral i - in mk40 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - --- index 64 big-endian -checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex64 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ - let j = fromIntegral i - in mk64 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - (PA.indexByteArray arr (j + 5)) - (PA.indexByteArray arr (j + 6)) - (PA.indexByteArray arr (j + 7)) - -checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBounds name l w act - | w < fromIntegral l = act - | otherwise = pure $ Left err - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue w) - --- Performs a bounds check on a byte array. Strategy is as follows: --- --- isz = signed array size-in-bytes --- off = unsigned byte offset into the array --- esz = unsigned number of bytes to be read --- --- 1. Turn the signed size-in-bytes of the array unsigned --- 2. Add the offset to the to-be-read number to get the maximum size needed --- 3. Check that the actual array size is at least as big as the needed size --- 4. Check that the offset is less than the size --- --- Step 4 ensures that step 3 has not overflowed. Since an actual array size can --- only be 63 bits (since it is signed), the only way for 3 to overflow is if --- the offset is larger than a possible array size, since it would need to be --- 2^64-k, where k is the small (<=8) number of bytes to be read. -checkBoundsPrim :: - Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBoundsPrim name isz off esz act - | w > bsz || off > bsz = pure $ Left err - | otherwise = act - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue off) - - bsz = fromIntegral isz - w = off + esz + declareForeign Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 + declareForeign Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 + declareForeign Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 + declareForeign Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 + declareForeign Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 + declareForeign Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 + + declareForeign Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes + declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes + + declareForeign Untracked "crypto.hash" crypto'hash Crypto_hash + declareForeign Untracked "crypto.hmac" crypto'hmac Crypto_hmac + declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl + + declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash + declareForeign Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes + declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress + declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress + declareForeign Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress + declareForeign Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress + + declareForeign Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 + declareForeign Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 + declareForeign Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 + declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 + declareForeign Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 + declareForeign Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 + declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded + + declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be + declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le + declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be + declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le + declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be + declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le + + declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be + declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le + declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be + declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le + declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be + declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le + + declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force + + declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size + declareForeign Untracked "MutableArray.size" (argNDirect 1) MutableArray_size + declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size + declareForeign Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size + + declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign Untracked "MutableArray.read" arg2ToExn MutableArray_read + declareForeign Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 + declareForeign Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be + declareForeign Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be + declareForeign Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be + declareForeign Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be + declareForeign Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be + + declareForeign Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write + declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 + declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be + declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be + declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be + + declareForeign Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read + declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 + declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be + declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be + declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be + declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be + declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be + + declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force + declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force + + declareForeign Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze + declareForeign Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze + + declareForeign Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length + + declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length + + declareForeign Tracked "IO.array" (argNDirect 1) IO_array + declareForeign Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf + declareForeign Tracked "IO.bytearray" (argNDirect 1) IO_bytearray + declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf + + declareForeign Untracked "Scope.array" (argNDirect 1) Scope_array + declareForeign Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf + declareForeign Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray + declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf + + declareForeign Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal + declareForeign Untracked "Text.patterns.digit" direct Text_patterns_digit + declareForeign Untracked "Text.patterns.letter" direct Text_patterns_letter + declareForeign Untracked "Text.patterns.space" direct Text_patterns_space + declareForeign Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation + declareForeign Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar + declareForeign Untracked "Text.patterns.eof" direct Text_patterns_eof + declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange + declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange + declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn + declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn + declareForeign Untracked "Pattern.many" (argNDirect 1) Pattern_many + declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected + declareForeign Untracked "Pattern.capture" (argNDirect 1) Pattern_capture + declareForeign Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs + declareForeign Untracked "Pattern.join" (argNDirect 1) Pattern_join + declareForeign Untracked "Pattern.or" (argNDirect 2) Pattern_or + declareForeign Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate + + declareForeign Untracked "Pattern.run" arg2ToMaybeTup Pattern_run + + declareForeign Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch + + declareForeign Untracked "Char.Class.any" direct Char_Class_any + declareForeign Untracked "Char.Class.not" (argNDirect 1) Char_Class_not + declareForeign Untracked "Char.Class.and" (argNDirect 2) Char_Class_and + declareForeign Untracked "Char.Class.or" (argNDirect 2) Char_Class_or + declareForeign Untracked "Char.Class.range" (argNDirect 2) Char_Class_range + declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf + declareForeign Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric + declareForeign Untracked "Char.Class.upper" direct Char_Class_upper + declareForeign Untracked "Char.Class.lower" direct Char_Class_lower + declareForeign Untracked "Char.Class.whitespace" direct Char_Class_whitespace + declareForeign Untracked "Char.Class.control" direct Char_Class_control + declareForeign Untracked "Char.Class.printable" direct Char_Class_printable + declareForeign Untracked "Char.Class.mark" direct Char_Class_mark + declareForeign Untracked "Char.Class.number" direct Char_Class_number + declareForeign Untracked "Char.Class.punctuation" direct Char_Class_punctuation + declareForeign Untracked "Char.Class.symbol" direct Char_Class_symbol + declareForeign Untracked "Char.Class.separator" direct Char_Class_separator + declareForeign Untracked "Char.Class.letter" direct Char_Class_letter + declareForeign Untracked "Char.Class.is" (argNDirect 2) Char_Class_is + declareForeign Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char foreignDeclResults :: Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) @@ -2805,8 +2122,10 @@ builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m sandboxedForeigns :: EnumMap Word64 ForeignFunc sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m -builtinForeignNames :: EnumMap Word64 Data.Text.Text -builtinForeignNames | (_, _, m) <- foreignDeclResults False = fst <$> m +builtinForeignNames :: Map ANF.ForeignFunc Data.Text.Text +builtinForeignNames + | (_, _, m) <- foreignDeclResults False = + m -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index e16b548d69..44b3566530 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -6,10 +6,7 @@ {-# LANGUAGE ViewPatterns #-} module Unison.Runtime.Foreign.Function - ( ForeignFunc (..), - ForeignConvention (..), - ForeignFunc' (..), - mkForeign, + ( ForeignConvention (..), ) where @@ -33,7 +30,6 @@ import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) import Unison.Runtime.Array qualified as PA import Unison.Runtime.Exception import Unison.Runtime.Foreign -import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Type ( iarrayRef, @@ -51,42 +47,12 @@ import Unison.Util.Bytes (Bytes) import Unison.Util.RefPromise (Promise) import Unison.Util.Text (Text, pack, unpack) --- Foreign functions operating on stacks -data ForeignFunc where - FF :: - (Stack -> Args -> IO a) -> - (Stack -> r -> IO Stack) -> - (a -> IO r) -> - ForeignFunc - -instance Show ForeignFunc where - show _ = "ForeignFunc" - -instance Eq ForeignFunc where - _ == _ = internalBug "Eq ForeignFunc" - -instance Ord ForeignFunc where - compare _ _ = internalBug "Ord ForeignFunc" - class ForeignConvention a where readForeign :: [Int] -> Stack -> IO ([Int], a) writeForeign :: Stack -> a -> IO Stack -mkForeign :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeign ev = FF readArgs writeForeign ev - where - readArgs stk (argsToLists -> args) = - readForeign args stk >>= \case - ([], a) -> pure a - _ -> - internalBug - "mkForeign: too many arguments for foreign function" - instance ForeignConvention Int where readForeign (i : args) stk = (args,) <$> peekOffI stk i readForeign [] _ = foreignCCError "Int" diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index f22a6ebcd4..23d2a2e49e 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} - module Unison.Runtime.Foreign.Impl (foreignCall) where import Control.Concurrent (ThreadId) @@ -11,12 +9,9 @@ import Control.Concurrent.MVar as SYS import Control.Concurrent.STM qualified as STM import Control.DeepSeq (NFData) import Control.Exception -import Control.Exception (evaluate) import Control.Exception.Safe qualified as Exception import Control.Monad.Catch (MonadCatch) import Control.Monad.Primitive qualified as PA -import Control.Monad.Reader (ReaderT (..), ask, runReaderT) -import Control.Monad.State.Strict (State, execState, modify) import Crypto.Error (CryptoError (..), CryptoFailable (..)) import Crypto.Hash qualified as Hash import Crypto.MAC.HMAC qualified as HMAC @@ -30,10 +25,7 @@ import Data.ByteString.Lazy qualified as L import Data.Default (def) import Data.Digest.Murmur64 (asWord64, hash64) import Data.IP (IP) -import Data.Map qualified as Map import Data.PEM (PEM, pemContent, pemParseLBS) -import Data.Set (insert) -import Data.Set qualified as Set import Data.Text qualified import Data.Text.IO qualified as Text.IO import Data.Time.Clock.POSIX as SYS @@ -129,34 +121,25 @@ import System.Process as SYS withCreateProcess, ) import System.X509 qualified as X -import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Referent (Referent, pattern Ref) -import Unison.Runtime.ANF as ANF +import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize as ANF +import Unison.Runtime.ANF.Serialize qualified as ANF import Unison.Runtime.Array qualified as PA import Unison.Runtime.Builtin -import Unison.Runtime.Builtin.Types -import Unison.Runtime.Crypto.Rsa as Rsa +import Unison.Runtime.Crypto.Rsa qualified as Rsa import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign - ( Foreign (Wrap), - HashAlgorithm (..), - ) import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function hiding (mkForeign) +import Unison.Runtime.Foreign.Function (ForeignConvention (..)) import Unison.Runtime.MCode import Unison.Runtime.Stack -import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) -import Unison.Runtime.Stack qualified as Closure import Unison.Symbol import Unison.Type qualified as Ty import Unison.Util.Bytes qualified as Bytes -import Unison.Util.EnumContainers as EC import Unison.Util.RefPromise ( Promise, newPromise, @@ -167,10 +150,9 @@ import Unison.Util.RefPromise import Unison.Util.Text (Text) import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat -import Unison.Var import UnliftIO qualified -foreignCall :: ForeignFunc' -> Args -> Stack -> IO Stack +foreignCall :: MForeignFunc -> Args -> Stack -> IO Stack foreignCall = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host @@ -474,31 +456,31 @@ foreignCall = \case Tls_terminate_impl_v3 -> mkForeignTls $ \(tls :: TLS.Context) -> TLS.bye tls Code_validateLinks -> mkForeign $ - \(lsgs0 :: [(Referent, Code)]) -> do + \(lsgs0 :: [(Referent, ANF.Code)]) -> do let f (msg, rs) = F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs pure . first f $ checkGroupHashes lsgs0 Code_dependencies -> mkForeign $ - \(CodeRep sg _) -> - pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg + \(ANF.CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg Code_serialize -> mkForeign $ - \(co :: Code) -> - pure . Bytes.fromArray $ serializeCode builtinForeignNames co + \(co :: ANF.Code) -> + pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co Code_deserialize -> mkForeign $ - pure . deserializeCode . Bytes.toArray + pure . ANF.deserializeCode . Bytes.toArray Code_display -> mkForeign $ - \(nm, (CodeRep sg _)) -> - pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" + \(nm, (ANF.CodeRep sg _)) -> + pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" Value_dependencies -> mkForeign $ - pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks + pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks Value_serialize -> mkForeign $ - pure . Bytes.fromArray . serializeValue + pure . Bytes.fromArray . ANF.serializeValue Value_deserialize -> mkForeign $ - pure . deserializeValue . Bytes.toArray + pure . ANF.deserializeValue . Bytes.toArray Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 @@ -526,7 +508,7 @@ foreignCall = \case L.ByteString -> Hash.Digest a hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x + in pure . Bytes.fromArray . hashlazy alg $ ANF.serializeValueForHash x Crypto_hmac -> mkForeign $ \(HashAlgorithm _ alg, key, x) -> let hmac :: @@ -536,7 +518,7 @@ foreignCall = \case . HMAC.updates (HMAC.initialize $ Bytes.toArray @BA.Bytes key) $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x + in pure . Bytes.fromArray . hmac alg $ ANF.serializeValueForHash x Crypto_Ed25519_sign_impl -> mkForeign $ pure . signEd25519Wrapper @@ -551,7 +533,7 @@ foreignCall = \case pure . verifyRsaWrapper Universal_murmurHash -> mkForeign $ - pure . asWord64 . hash64 . serializeValueForHash + pure . asWord64 . hash64 . ANF.serializeValueForHash IO_randomBytes -> mkForeign $ \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 010513d481..83e9d5aa7b 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -35,7 +35,7 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, - ForeignFunc' (..), + MForeignFunc (..), emitCombs, emitComb, resolveCombs, @@ -461,7 +461,7 @@ data BPrim2 deriving (Show, Eq, Ord, Enum, Bounded) -- | Enum representing every foreign call. -data ForeignFunc' +data MForeignFunc = IO_UDP_clientSocket_impl_v1 | IO_UDP_UDPSocket_recv_impl_v1 | IO_UDP_UDPSocket_send_impl_v1 @@ -748,16 +748,10 @@ data GInstr comb | -- Use a check-and-set ticket to update a reference -- (ref stack index, ticket stack index, new value stack index) RefCAS !Int !Int !Int - | -- Call out to a Haskell function. This is considerably slower - -- for very simple operations, hence the primops. - ForeignCall - !Bool -- catch exceptions - !Word64 -- FFI call - !Args -- arguments | -- Call out to a Haskell function. - ForeignCall' + ForeignCall !Bool -- catch exceptions - !ForeignFunc' -- FFI call + !MForeignFunc -- FFI call !Args -- arguments | -- Set the value of a dynamic reference SetDyn @@ -1649,8 +1643,257 @@ emitPOp ANF.TFRC = \case -- to 'foreing function' calls, but there is a special case for the -- standard handle access function, because it does not yield an -- explicit error. -emitFOp :: ANF.FOp -> Args -> Instr -emitFOp fop = ForeignCall True (fromIntegral $ fromEnum fop) +emitFOp :: ANF.ForeignFunc -> Args -> Instr +emitFOp fop = ForeignCall True (convertFF fop) + where + convertFF :: ANF.ForeignFunc -> MForeignFunc + convertFF = \case + ANF.IO_UDP_clientSocket_impl_v1 -> IO_UDP_clientSocket_impl_v1 + ANF.IO_UDP_UDPSocket_recv_impl_v1 -> IO_UDP_UDPSocket_recv_impl_v1 + ANF.IO_UDP_UDPSocket_send_impl_v1 -> IO_UDP_UDPSocket_send_impl_v1 + ANF.IO_UDP_UDPSocket_close_impl_v1 -> IO_UDP_UDPSocket_close_impl_v1 + ANF.IO_UDP_ListenSocket_close_impl_v1 -> IO_UDP_ListenSocket_close_impl_v1 + ANF.IO_UDP_UDPSocket_toText_impl_v1 -> IO_UDP_UDPSocket_toText_impl_v1 + ANF.IO_UDP_serverSocket_impl_v1 -> IO_UDP_serverSocket_impl_v1 + ANF.IO_UDP_ListenSocket_toText_impl_v1 -> IO_UDP_ListenSocket_toText_impl_v1 + ANF.IO_UDP_ListenSocket_recvFrom_impl_v1 -> IO_UDP_ListenSocket_recvFrom_impl_v1 + ANF.IO_UDP_ClientSockAddr_toText_v1 -> IO_UDP_ClientSockAddr_toText_v1 + ANF.IO_UDP_ListenSocket_sendTo_impl_v1 -> IO_UDP_ListenSocket_sendTo_impl_v1 + ANF.IO_openFile_impl_v3 -> IO_openFile_impl_v3 + ANF.IO_closeFile_impl_v3 -> IO_closeFile_impl_v3 + ANF.IO_isFileEOF_impl_v3 -> IO_isFileEOF_impl_v3 + ANF.IO_isFileOpen_impl_v3 -> IO_isFileOpen_impl_v3 + ANF.IO_getEcho_impl_v1 -> IO_getEcho_impl_v1 + ANF.IO_ready_impl_v1 -> IO_ready_impl_v1 + ANF.IO_getChar_impl_v1 -> IO_getChar_impl_v1 + ANF.IO_isSeekable_impl_v3 -> IO_isSeekable_impl_v3 + ANF.IO_seekHandle_impl_v3 -> IO_seekHandle_impl_v3 + ANF.IO_handlePosition_impl_v3 -> IO_handlePosition_impl_v3 + ANF.IO_getBuffering_impl_v3 -> IO_getBuffering_impl_v3 + ANF.IO_setBuffering_impl_v3 -> IO_setBuffering_impl_v3 + ANF.IO_setEcho_impl_v1 -> IO_setEcho_impl_v1 + ANF.IO_getLine_impl_v1 -> IO_getLine_impl_v1 + ANF.IO_getBytes_impl_v3 -> IO_getBytes_impl_v3 + ANF.IO_getSomeBytes_impl_v1 -> IO_getSomeBytes_impl_v1 + ANF.IO_putBytes_impl_v3 -> IO_putBytes_impl_v3 + ANF.IO_systemTime_impl_v3 -> IO_systemTime_impl_v3 + ANF.IO_systemTimeMicroseconds_v1 -> IO_systemTimeMicroseconds_v1 + ANF.Clock_internals_monotonic_v1 -> Clock_internals_monotonic_v1 + ANF.Clock_internals_realtime_v1 -> Clock_internals_realtime_v1 + ANF.Clock_internals_processCPUTime_v1 -> Clock_internals_processCPUTime_v1 + ANF.Clock_internals_threadCPUTime_v1 -> Clock_internals_threadCPUTime_v1 + ANF.Clock_internals_sec_v1 -> Clock_internals_sec_v1 + ANF.Clock_internals_nsec_v1 -> Clock_internals_nsec_v1 + ANF.Clock_internals_systemTimeZone_v1 -> Clock_internals_systemTimeZone_v1 + ANF.IO_getTempDirectory_impl_v3 -> IO_getTempDirectory_impl_v3 + ANF.IO_createTempDirectory_impl_v3 -> IO_createTempDirectory_impl_v3 + ANF.IO_getCurrentDirectory_impl_v3 -> IO_getCurrentDirectory_impl_v3 + ANF.IO_setCurrentDirectory_impl_v3 -> IO_setCurrentDirectory_impl_v3 + ANF.IO_fileExists_impl_v3 -> IO_fileExists_impl_v3 + ANF.IO_getEnv_impl_v1 -> IO_getEnv_impl_v1 + ANF.IO_getArgs_impl_v1 -> IO_getArgs_impl_v1 + ANF.IO_isDirectory_impl_v3 -> IO_isDirectory_impl_v3 + ANF.IO_createDirectory_impl_v3 -> IO_createDirectory_impl_v3 + ANF.IO_removeDirectory_impl_v3 -> IO_removeDirectory_impl_v3 + ANF.IO_renameDirectory_impl_v3 -> IO_renameDirectory_impl_v3 + ANF.IO_directoryContents_impl_v3 -> IO_directoryContents_impl_v3 + ANF.IO_removeFile_impl_v3 -> IO_removeFile_impl_v3 + ANF.IO_renameFile_impl_v3 -> IO_renameFile_impl_v3 + ANF.IO_getFileTimestamp_impl_v3 -> IO_getFileTimestamp_impl_v3 + ANF.IO_getFileSize_impl_v3 -> IO_getFileSize_impl_v3 + ANF.IO_serverSocket_impl_v3 -> IO_serverSocket_impl_v3 + ANF.Socket_toText -> Socket_toText + ANF.Handle_toText -> Handle_toText + ANF.ThreadId_toText -> ThreadId_toText + ANF.IO_socketPort_impl_v3 -> IO_socketPort_impl_v3 + ANF.IO_listen_impl_v3 -> IO_listen_impl_v3 + ANF.IO_clientSocket_impl_v3 -> IO_clientSocket_impl_v3 + ANF.IO_closeSocket_impl_v3 -> IO_closeSocket_impl_v3 + ANF.IO_socketAccept_impl_v3 -> IO_socketAccept_impl_v3 + ANF.IO_socketSend_impl_v3 -> IO_socketSend_impl_v3 + ANF.IO_socketReceive_impl_v3 -> IO_socketReceive_impl_v3 + ANF.IO_kill_impl_v3 -> IO_kill_impl_v3 + ANF.IO_delay_impl_v3 -> IO_delay_impl_v3 + ANF.IO_stdHandle -> IO_stdHandle + ANF.IO_process_call -> IO_process_call + ANF.IO_process_start -> IO_process_start + ANF.IO_process_kill -> IO_process_kill + ANF.IO_process_wait -> IO_process_wait + ANF.IO_process_exitCode -> IO_process_exitCode + ANF.MVar_new -> MVar_new + ANF.MVar_newEmpty_v2 -> MVar_newEmpty_v2 + ANF.MVar_take_impl_v3 -> MVar_take_impl_v3 + ANF.MVar_tryTake -> MVar_tryTake + ANF.MVar_put_impl_v3 -> MVar_put_impl_v3 + ANF.MVar_tryPut_impl_v3 -> MVar_tryPut_impl_v3 + ANF.MVar_swap_impl_v3 -> MVar_swap_impl_v3 + ANF.MVar_isEmpty -> MVar_isEmpty + ANF.MVar_read_impl_v3 -> MVar_read_impl_v3 + ANF.MVar_tryRead_impl_v3 -> MVar_tryRead_impl_v3 + ANF.Char_toText -> Char_toText + ANF.Text_repeat -> Text_repeat + ANF.Text_reverse -> Text_reverse + ANF.Text_toUppercase -> Text_toUppercase + ANF.Text_toLowercase -> Text_toLowercase + ANF.Text_toUtf8 -> Text_toUtf8 + ANF.Text_fromUtf8_impl_v3 -> Text_fromUtf8_impl_v3 + ANF.Tls_ClientConfig_default -> Tls_ClientConfig_default + ANF.Tls_ServerConfig_default -> Tls_ServerConfig_default + ANF.Tls_ClientConfig_certificates_set -> Tls_ClientConfig_certificates_set + ANF.Tls_ServerConfig_certificates_set -> Tls_ServerConfig_certificates_set + ANF.TVar_new -> TVar_new + ANF.TVar_read -> TVar_read + ANF.TVar_write -> TVar_write + ANF.TVar_newIO -> TVar_newIO + ANF.TVar_readIO -> TVar_readIO + ANF.TVar_swap -> TVar_swap + ANF.STM_retry -> STM_retry + ANF.Promise_new -> Promise_new + ANF.Promise_read -> Promise_read + ANF.Promise_tryRead -> Promise_tryRead + ANF.Promise_write -> Promise_write + ANF.Tls_newClient_impl_v3 -> Tls_newClient_impl_v3 + ANF.Tls_newServer_impl_v3 -> Tls_newServer_impl_v3 + ANF.Tls_handshake_impl_v3 -> Tls_handshake_impl_v3 + ANF.Tls_send_impl_v3 -> Tls_send_impl_v3 + ANF.Tls_decodeCert_impl_v3 -> Tls_decodeCert_impl_v3 + ANF.Tls_encodeCert -> Tls_encodeCert + ANF.Tls_decodePrivateKey -> Tls_decodePrivateKey + ANF.Tls_encodePrivateKey -> Tls_encodePrivateKey + ANF.Tls_receive_impl_v3 -> Tls_receive_impl_v3 + ANF.Tls_terminate_impl_v3 -> Tls_terminate_impl_v3 + ANF.Code_validateLinks -> Code_validateLinks + ANF.Code_dependencies -> Code_dependencies + ANF.Code_serialize -> Code_serialize + ANF.Code_deserialize -> Code_deserialize + ANF.Code_display -> Code_display + ANF.Value_dependencies -> Value_dependencies + ANF.Value_serialize -> Value_serialize + ANF.Value_deserialize -> Value_deserialize + ANF.Crypto_HashAlgorithm_Sha3_512 -> Crypto_HashAlgorithm_Sha3_512 + ANF.Crypto_HashAlgorithm_Sha3_256 -> Crypto_HashAlgorithm_Sha3_256 + ANF.Crypto_HashAlgorithm_Sha2_512 -> Crypto_HashAlgorithm_Sha2_512 + ANF.Crypto_HashAlgorithm_Sha2_256 -> Crypto_HashAlgorithm_Sha2_256 + ANF.Crypto_HashAlgorithm_Sha1 -> Crypto_HashAlgorithm_Sha1 + ANF.Crypto_HashAlgorithm_Blake2b_512 -> Crypto_HashAlgorithm_Blake2b_512 + ANF.Crypto_HashAlgorithm_Blake2b_256 -> Crypto_HashAlgorithm_Blake2b_256 + ANF.Crypto_HashAlgorithm_Blake2s_256 -> Crypto_HashAlgorithm_Blake2s_256 + ANF.Crypto_HashAlgorithm_Md5 -> Crypto_HashAlgorithm_Md5 + ANF.Crypto_hashBytes -> Crypto_hashBytes + ANF.Crypto_hmacBytes -> Crypto_hmacBytes + ANF.Crypto_hash -> Crypto_hash + ANF.Crypto_hmac -> Crypto_hmac + ANF.Crypto_Ed25519_sign_impl -> Crypto_Ed25519_sign_impl + ANF.Crypto_Ed25519_verify_impl -> Crypto_Ed25519_verify_impl + ANF.Crypto_Rsa_sign_impl -> Crypto_Rsa_sign_impl + ANF.Crypto_Rsa_verify_impl -> Crypto_Rsa_verify_impl + ANF.Universal_murmurHash -> Universal_murmurHash + ANF.IO_randomBytes -> IO_randomBytes + ANF.Bytes_zlib_compress -> Bytes_zlib_compress + ANF.Bytes_gzip_compress -> Bytes_gzip_compress + ANF.Bytes_zlib_decompress -> Bytes_zlib_decompress + ANF.Bytes_gzip_decompress -> Bytes_gzip_decompress + ANF.Bytes_toBase16 -> Bytes_toBase16 + ANF.Bytes_toBase32 -> Bytes_toBase32 + ANF.Bytes_toBase64 -> Bytes_toBase64 + ANF.Bytes_toBase64UrlUnpadded -> Bytes_toBase64UrlUnpadded + ANF.Bytes_fromBase16 -> Bytes_fromBase16 + ANF.Bytes_fromBase32 -> Bytes_fromBase32 + ANF.Bytes_fromBase64 -> Bytes_fromBase64 + ANF.Bytes_fromBase64UrlUnpadded -> Bytes_fromBase64UrlUnpadded + ANF.Bytes_decodeNat64be -> Bytes_decodeNat64be + ANF.Bytes_decodeNat64le -> Bytes_decodeNat64le + ANF.Bytes_decodeNat32be -> Bytes_decodeNat32be + ANF.Bytes_decodeNat32le -> Bytes_decodeNat32le + ANF.Bytes_decodeNat16be -> Bytes_decodeNat16be + ANF.Bytes_decodeNat16le -> Bytes_decodeNat16le + ANF.Bytes_encodeNat64be -> Bytes_encodeNat64be + ANF.Bytes_encodeNat64le -> Bytes_encodeNat64le + ANF.Bytes_encodeNat32be -> Bytes_encodeNat32be + ANF.Bytes_encodeNat32le -> Bytes_encodeNat32le + ANF.Bytes_encodeNat16be -> Bytes_encodeNat16be + ANF.Bytes_encodeNat16le -> Bytes_encodeNat16le + ANF.MutableArray_copyTo_force -> MutableArray_copyTo_force + ANF.MutableByteArray_copyTo_force -> MutableByteArray_copyTo_force + ANF.ImmutableArray_copyTo_force -> ImmutableArray_copyTo_force + ANF.ImmutableArray_size -> ImmutableArray_size + ANF.MutableArray_size -> MutableArray_size + ANF.ImmutableByteArray_size -> ImmutableByteArray_size + ANF.MutableByteArray_size -> MutableByteArray_size + ANF.ImmutableByteArray_copyTo_force -> ImmutableByteArray_copyTo_force + ANF.MutableArray_read -> MutableArray_read + ANF.MutableByteArray_read8 -> MutableByteArray_read8 + ANF.MutableByteArray_read16be -> MutableByteArray_read16be + ANF.MutableByteArray_read24be -> MutableByteArray_read24be + ANF.MutableByteArray_read32be -> MutableByteArray_read32be + ANF.MutableByteArray_read40be -> MutableByteArray_read40be + ANF.MutableByteArray_read64be -> MutableByteArray_read64be + ANF.MutableArray_write -> MutableArray_write + ANF.MutableByteArray_write8 -> MutableByteArray_write8 + ANF.MutableByteArray_write16be -> MutableByteArray_write16be + ANF.MutableByteArray_write32be -> MutableByteArray_write32be + ANF.MutableByteArray_write64be -> MutableByteArray_write64be + ANF.ImmutableArray_read -> ImmutableArray_read + ANF.ImmutableByteArray_read8 -> ImmutableByteArray_read8 + ANF.ImmutableByteArray_read16be -> ImmutableByteArray_read16be + ANF.ImmutableByteArray_read24be -> ImmutableByteArray_read24be + ANF.ImmutableByteArray_read32be -> ImmutableByteArray_read32be + ANF.ImmutableByteArray_read40be -> ImmutableByteArray_read40be + ANF.ImmutableByteArray_read64be -> ImmutableByteArray_read64be + ANF.MutableByteArray_freeze_force -> MutableByteArray_freeze_force + ANF.MutableArray_freeze_force -> MutableArray_freeze_force + ANF.MutableByteArray_freeze -> MutableByteArray_freeze + ANF.MutableArray_freeze -> MutableArray_freeze + ANF.MutableByteArray_length -> MutableByteArray_length + ANF.ImmutableByteArray_length -> ImmutableByteArray_length + ANF.IO_array -> IO_array + ANF.IO_arrayOf -> IO_arrayOf + ANF.IO_bytearray -> IO_bytearray + ANF.IO_bytearrayOf -> IO_bytearrayOf + ANF.Scope_array -> Scope_array + ANF.Scope_arrayOf -> Scope_arrayOf + ANF.Scope_bytearray -> Scope_bytearray + ANF.Scope_bytearrayOf -> Scope_bytearrayOf + ANF.Text_patterns_literal -> Text_patterns_literal + ANF.Text_patterns_digit -> Text_patterns_digit + ANF.Text_patterns_letter -> Text_patterns_letter + ANF.Text_patterns_space -> Text_patterns_space + ANF.Text_patterns_punctuation -> Text_patterns_punctuation + ANF.Text_patterns_anyChar -> Text_patterns_anyChar + ANF.Text_patterns_eof -> Text_patterns_eof + ANF.Text_patterns_charRange -> Text_patterns_charRange + ANF.Text_patterns_notCharRange -> Text_patterns_notCharRange + ANF.Text_patterns_charIn -> Text_patterns_charIn + ANF.Text_patterns_notCharIn -> Text_patterns_notCharIn + ANF.Pattern_many -> Pattern_many + ANF.Pattern_many_corrected -> Pattern_many_corrected + ANF.Pattern_capture -> Pattern_capture + ANF.Pattern_captureAs -> Pattern_captureAs + ANF.Pattern_join -> Pattern_join + ANF.Pattern_or -> Pattern_or + ANF.Pattern_replicate -> Pattern_replicate + ANF.Pattern_run -> Pattern_run + ANF.Pattern_isMatch -> Pattern_isMatch + ANF.Char_Class_any -> Char_Class_any + ANF.Char_Class_not -> Char_Class_not + ANF.Char_Class_and -> Char_Class_and + ANF.Char_Class_or -> Char_Class_or + ANF.Char_Class_range -> Char_Class_range + ANF.Char_Class_anyOf -> Char_Class_anyOf + ANF.Char_Class_alphanumeric -> Char_Class_alphanumeric + ANF.Char_Class_upper -> Char_Class_upper + ANF.Char_Class_lower -> Char_Class_lower + ANF.Char_Class_whitespace -> Char_Class_whitespace + ANF.Char_Class_control -> Char_Class_control + ANF.Char_Class_printable -> Char_Class_printable + ANF.Char_Class_mark -> Char_Class_mark + ANF.Char_Class_number -> Char_Class_number + ANF.Char_Class_punctuation -> Char_Class_punctuation + ANF.Char_Class_symbol -> Char_Class_symbol + ANF.Char_Class_separator -> Char_Class_separator + ANF.Char_Class_letter -> Char_Class_letter + ANF.Char_Class_is -> Char_Class_is + ANF.Text_patterns_char -> Text_patterns_char -- Helper functions for packing the variable argument representation -- into the indexes stored in prim op instructions diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index b6f6cf66b3..f8cc373541 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -49,11 +49,10 @@ import Unison.Runtime.ANF as ANF ) import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.Array as PA -import Unison.Runtime.Builtin +import Unison.Runtime.Builtin hiding (unitValue) import Unison.Runtime.Exception import Unison.Runtime.Foreign -import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function +import Unison.Runtime.Foreign.Impl (foreignCall) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Runtime.TypeTags qualified as TT @@ -110,8 +109,7 @@ data Tracer -- code caching environment data CCache = CCache - { foreignFuncs :: EnumMap Word64 ForeignFunc, - sandboxed :: Bool, + { sandboxed :: Bool, tracer :: Bool -> Val -> Tracer, -- Combinators in their original form, where they're easier to serialize into SCache srcCombs :: TVar (EnumMap Word64 Combs), @@ -151,7 +149,7 @@ refNumTy' cc r = M.lookup r <$> refNumsTy cc baseCCache :: Bool -> IO CCache baseCCache sandboxed = do - CCache ffuncs sandboxed noTrace + CCache sandboxed noTrace <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO builtinTermBackref @@ -165,7 +163,6 @@ baseCCache sandboxed = do <*> newTVarIO baseSandboxInfo where cacheableCombs = mempty - ffuncs | sandboxed = sandboxedForeigns | otherwise = builtinForeigns noTrace _ _ = NoTrace ftm = 1 + maximum builtinTermNumbering fty = 1 + maximum builtinTypeNumbering @@ -602,14 +599,8 @@ exec !_ !denv !_activeThreads !stk !k _ (Seq as) = do stk <- bump stk pokeS stk $ Sq.fromList l pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (ForeignCall _ w args) - | Just (FF arg res ev) <- EC.lookup w (foreignFuncs env) = - (denv,,k) - <$> (arg stk args >>= ev >>= res stk) - | otherwise = - die $ "reference to unknown foreign function: " ++ show w -exec !_env !denv !_activeThreads !stk !k _ (ForeignCall' _ func args) = - (denv,,k) <$> foreignCall args func stk +exec !_env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = + (denv,,k) <$> foreignCall func args stk exec !env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do From d53b00b52be5d849cf49bb3250fe4a55f05951ac Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 5 Dec 2024 11:39:16 -0800 Subject: [PATCH 5/6] Remove all the old sandboxing --- .../src/Unison/Runtime/ANF/Serialize.hs | 21 ++++---- unison-runtime/src/Unison/Runtime/Builtin.hs | 52 +++++-------------- .../src/Unison/Runtime/Interface.hs | 2 +- unison-runtime/src/Unison/Runtime/MCode.hs | 7 ++- .../src/Unison/Runtime/MCode/Serialize.hs | 18 ++++++- unison-runtime/src/Unison/Runtime/Machine.hs | 2 + 6 files changed, 47 insertions(+), 55 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index fd223aba71..9ce7c5db50 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -26,7 +26,6 @@ import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Runtime.Exception import Unison.Runtime.Serialize -import Unison.Util.EnumContainers qualified as EC import Unison.Util.Text qualified as Util.Text import Unison.Var (Type (ANFBlank), Var (..)) import Prelude hiding (getChar, putChar) @@ -317,7 +316,7 @@ putGroup :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> SuperGroup v -> m () putGroup refrep fops (Rec bs e) = @@ -338,7 +337,7 @@ getGroup = do cs <- replicateM l (getComb ctx n) Rec (zip vs cs) <$> getComb ctx n -putCode :: (MonadPut m) => EC.EnumMap ForeignFunc Text -> Code -> m () +putCode :: (MonadPut m) => Map ForeignFunc Text -> Code -> m () putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c getCode :: (MonadGet m) => Word32 -> m Code @@ -363,7 +362,7 @@ putComb :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> SuperNormal v -> m () @@ -384,7 +383,7 @@ putNormal :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> ANormal v -> m () @@ -482,7 +481,7 @@ putFunc :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> Func v -> m () @@ -496,7 +495,7 @@ putFunc refrep fops ctx f = case f of FReq r c -> putTag FReqT *> putReference r *> putCTag c FPrim (Left p) -> putTag FPrimT *> putPOp p FPrim (Right f) - | Just nm <- EC.lookup f fops -> + | Just nm <- Map.lookup f fops -> putTag FForeignT *> putText nm | otherwise -> exn $ "putFunc: could not serialize foreign operation: " ++ show f @@ -757,7 +756,7 @@ putBranches :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> Branched (ANormal v) -> m () @@ -825,7 +824,7 @@ putCase :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> [v] -> ([Mem], ANormal v) -> m () @@ -997,7 +996,7 @@ deserializeCode bs = runGetS (getVersion >>= getCode) bs n | 1 <= n && n <= 3 -> pure n n -> fail $ "deserializeGroup: unknown version: " ++ show n -serializeCode :: EC.EnumMap ForeignFunc Text -> Code -> ByteString +serializeCode :: Map ForeignFunc Text -> Code -> ByteString serializeCode fops co = runPutS (putVersion *> putCode fops co) where putVersion = putWord32be codeVersion @@ -1023,7 +1022,7 @@ serializeCode fops co = runPutS (putVersion *> putCode fops co) -- shouldn't be subject to rehashing. serializeGroupForRehash :: (Var v) => - EC.EnumMap ForeignFunc Text -> + Map ForeignFunc Text -> Reference -> SuperGroup v -> L.ByteString diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6ef8783946..261318fe54 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -12,10 +12,8 @@ module Unison.Runtime.Builtin builtinTypeNumbering, builtinTermBackref, builtinTypeBackref, - builtinForeigns, builtinArities, builtinInlineInfo, - sandboxedForeigns, numberedTermLookup, Sandbox (..), baseSandboxInfo, @@ -25,23 +23,17 @@ module Unison.Runtime.Builtin ) where -import Control.Concurrent.STM qualified as STM -import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Control.Monad.State.Strict (State, execState, modify) import Data.Map qualified as Map import Data.Set (insert) import Data.Set qualified as Set import Data.Text qualified -import GHC.Conc qualified as STM -import GHC.IO (IO (IO)) import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Runtime.ANF as ANF import Unison.Runtime.Builtin.Types -import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol @@ -1696,8 +1688,7 @@ builtinLookup = ] ++ foreignWrappers -type FDecl v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], Map Word64 (Data.Text.Text, ForeignFunc))) +type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v, Data.Text.Text)) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1706,25 +1697,16 @@ type FDecl v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) -bomb :: Data.Text.Text -> a -> IO r -bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name - declareForeign :: Sandbox -> Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand name op func0 = do - sanitize <- ask - modify $ \(w, codes, funcs) -> - let func - | sanitize, - Tracked <- sand = - error "TODO: fill in sandboxing error" - | otherwise = func0 - code = (name, (sand, uncurry Lambda (op w))) - in (w + 1, code : codes, mapInsert w (name, func) funcs) +declareForeign sand name op func = do + modify $ \funcs -> + let code = uncurry Lambda (op func) + in (Map.insert func (sand, code, name) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -2096,13 +2078,14 @@ declareForeigns = do declareForeign Untracked "Char.Class.is" (argNDirect 2) Char_Class_is declareForeign Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char -foreignDeclResults :: - Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) -foreignDeclResults sanitize = - execState (runReaderT declareForeigns sanitize) (0, [], mempty) +foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol, Data.Text.Text)) +foreignDeclResults = + execState declareForeigns mempty foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] -foreignWrappers | (_, l, _) <- foreignDeclResults False = reverse l +foreignWrappers = + Map.elems foreignDeclResults + <&> \(sand, code, name) -> (name, (sand, code)) numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -2116,16 +2099,8 @@ builtinTermBackref :: EnumMap Word64 Reference builtinTermBackref = mapFromList . zip [1 ..] . Map.keys $ builtinLookup -builtinForeigns :: EnumMap Word64 ForeignFunc -builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m - -sandboxedForeigns :: EnumMap Word64 ForeignFunc -sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m - builtinForeignNames :: Map ANF.ForeignFunc Data.Text.Text -builtinForeignNames - | (_, _, m) <- foreignDeclResults False = - m +builtinForeignNames = foreignDeclResults <&> \(_, _, n) -> n -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base @@ -2146,6 +2121,3 @@ builtinArities = builtinInlineInfo :: Map Reference (Int, ANormal Symbol) builtinInlineInfo = ANF.buildInlineMap $ fmap (Rec [] . snd) builtinLookup - -unsafeSTMToIO :: STM.STM a -> IO a -unsafeSTMToIO (STM.STM m) = IO m diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index a9103e1ec4..bf353baf93 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -1321,7 +1321,7 @@ tabulateErrors errs = restoreCache :: StoredCache -> IO CCache restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do cc <- - CCache builtinForeigns False debugText + CCache False debugText <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO (crs <> builtinTermBackref) diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 83e9d5aa7b..977107613d 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -60,7 +60,7 @@ import Data.Functor ((<&>)) import Data.Map.Strict qualified as M import Data.Primitive.PrimArray import Data.Primitive.PrimArray qualified as PA -import Data.Text as Text (unpack) +import Data.Text qualified as Text import Data.Void (Void, absurd) import Data.Word (Word16, Word64) import GHC.Stack (HasCallStack) @@ -254,6 +254,9 @@ import Unison.Var (Var) -- certain recursive, 'deep' handlers, since those can operate -- more like stateful code than control operators. +data Sandboxed = Tracked | Untracked + deriving (Show, Eq, Ord) + data Args' = Arg1 !Int | Arg2 !Int !Int @@ -787,6 +790,8 @@ data GInstr comb Seq !Args | -- Force a delayed expression, catching any runtime exceptions involved TryForce !Int + | -- Attempted to use a builtin that was not allowed in the current sandboxing context. + SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed. deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) type Section = GSection CombIx diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 5d35608810..2b0fd4aa81 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -54,6 +54,13 @@ getComb = Lam <$> gInt <*> gInt <*> getSection CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" +getMForeignFunc :: (MonadGet m) => m MForeignFunc +getMForeignFunc = do + toEnum <$> gInt + +putMForeignFunc :: (MonadPut m) => MForeignFunc -> m () +putMForeignFunc = pInt . fromEnum + data SectionT = AppT | CallT @@ -161,6 +168,7 @@ data InstrT | SeqT | TryForceT | RefCAST + | SandboxingFailureT instance Tag InstrT where tag2word UPrim1T = 0 @@ -181,6 +189,7 @@ instance Tag InstrT where tag2word SeqT = 15 tag2word TryForceT = 16 tag2word RefCAST = 17 + tag2word SandboxingFailureT = 18 word2tag 0 = pure UPrim1T word2tag 1 = pure UPrim2T @@ -200,6 +209,7 @@ instance Tag InstrT where word2tag 15 = pure SeqT word2tag 16 = pure TryForceT word2tag 17 = pure RefCAST + word2tag 18 = pure SandboxingFailureT word2tag n = unknownTag "InstrT" n putInstr :: (MonadPut m) => GInstr cix -> m () @@ -209,7 +219,7 @@ putInstr = \case (BPrim1 bp i) -> putTag BPrim1T *> putTag bp *> pInt i (BPrim2 bp i j) -> putTag BPrim2T *> putTag bp *> pInt i *> pInt j (RefCAS i j k) -> putTag RefCAST *> pInt i *> pInt j *> pInt k - (ForeignCall b w a) -> putTag ForeignCallT *> serialize b *> pWord w *> putArgs a + (ForeignCall b ff a) -> putTag ForeignCallT *> serialize b *> putMForeignFunc ff *> putArgs a (SetDyn w i) -> putTag SetDynT *> pWord w *> pInt i (Capture w) -> putTag CaptureT *> pWord w (Name r a) -> putTag NameT *> putRef r *> putArgs a @@ -222,6 +232,9 @@ putInstr = \case (Atomically i) -> putTag AtomicallyT *> pInt i (Seq a) -> putTag SeqT *> putArgs a (TryForce i) -> putTag TryForceT *> pInt i + (SandboxingFailure {}) -> + -- Sandboxing failures should only exist in code we're actively running, it shouldn't be serialized. + error "putInstr: Unexpected serialized Sandboxing Failure" getInstr :: (MonadGet m) => m Instr getInstr = @@ -231,7 +244,7 @@ getInstr = BPrim1T -> BPrim1 <$> getTag <*> gInt BPrim2T -> BPrim2 <$> getTag <*> gInt <*> gInt RefCAST -> RefCAS <$> gInt <*> gInt <*> gInt - ForeignCallT -> ForeignCall <$> deserialize <*> gWord <*> getArgs + ForeignCallT -> ForeignCall <$> deserialize <*> getMForeignFunc <*> getArgs SetDynT -> SetDyn <$> gWord <*> gInt CaptureT -> Capture <$> gWord NameT -> Name <$> getRef <*> getArgs @@ -244,6 +257,7 @@ getInstr = AtomicallyT -> Atomically <$> gInt SeqT -> Seq <$> getArgs TryForceT -> TryForce <$> gInt + SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" data ArgsT = ZArgsT diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index f8cc373541..94a075b6b5 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -623,6 +623,8 @@ exec !env !denv !activeThreads !stk !k _ (TryForce i) ev <- Control.Exception.try $ nestEval env activeThreads (poke stk) v stk <- encodeExn stk ev pure (denv, stk, k) +exec !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do + die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t {-# INLINE exec #-} encodeExn :: From d3c9c691a02aff94dfb7ad747c938646af04b1c9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 6 Dec 2024 16:50:48 -0800 Subject: [PATCH 6/6] Sandbox foreigns with a preprocessing step. --- unison-cli/src/Unison/Main.hs | 2 +- unison-runtime/src/Unison/Runtime/ANF.hs | 252 +------- .../src/Unison/Runtime/ANF/Serialize.hs | 1 + unison-runtime/src/Unison/Runtime/Builtin.hs | 588 +++++++++--------- .../Unison/Runtime/Foreign/Function/Type.hs | 506 +++++++++++++++ .../src/Unison/Runtime/Foreign/Impl.hs | 3 +- .../src/Unison/Runtime/Interface.hs | 15 +- unison-runtime/src/Unison/Runtime/MCode.hs | 545 ++-------------- .../src/Unison/Runtime/MCode/Serialize.hs | 5 +- unison-runtime/src/Unison/Runtime/Machine.hs | 107 ++-- unison-runtime/unison-runtime.cabal | 1 + 11 files changed, 922 insertions(+), 1103 deletions(-) create mode 100644 unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 3624a50675..59845f0608 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -238,7 +238,7 @@ main version = do Right (Right (v, rf, combIx, sto)) | not vmatch -> mismatchMsg | otherwise -> - withArgs args (RTI.runStandalone sto combIx) >>= \case + withArgs args (RTI.runStandalone False sto combIx) >>= \case Left err -> exitError err Right () -> pure () where diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index b2350e5bf0..539b6bcd66 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -42,7 +42,6 @@ module Unison.Runtime.ANF SuperGroup (..), arities, POp (..), - ForeignFunc(..), close, saturate, float, @@ -117,6 +116,7 @@ import Unison.Prelude import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), maskTags, packTags, unpackTags) import Unison.Symbol (Symbol) import Unison.Term hiding (List, Ref, Text, arity, float, fresh, resolve) @@ -1436,256 +1436,6 @@ data POp | IORB -- or deriving (Show, Eq, Ord, Enum, Bounded) --- | Enum representing every foreign call. -data ForeignFunc - = IO_UDP_clientSocket_impl_v1 - | IO_UDP_UDPSocket_recv_impl_v1 - | IO_UDP_UDPSocket_send_impl_v1 - | IO_UDP_UDPSocket_close_impl_v1 - | IO_UDP_ListenSocket_close_impl_v1 - | IO_UDP_UDPSocket_toText_impl_v1 - | IO_UDP_serverSocket_impl_v1 - | IO_UDP_ListenSocket_toText_impl_v1 - | IO_UDP_ListenSocket_recvFrom_impl_v1 - | IO_UDP_ClientSockAddr_toText_v1 - | IO_UDP_ListenSocket_sendTo_impl_v1 - | IO_openFile_impl_v3 - | IO_closeFile_impl_v3 - | IO_isFileEOF_impl_v3 - | IO_isFileOpen_impl_v3 - | IO_getEcho_impl_v1 - | IO_ready_impl_v1 - | IO_getChar_impl_v1 - | IO_isSeekable_impl_v3 - | IO_seekHandle_impl_v3 - | IO_handlePosition_impl_v3 - | IO_getBuffering_impl_v3 - | IO_setBuffering_impl_v3 - | IO_setEcho_impl_v1 - | IO_getLine_impl_v1 - | IO_getBytes_impl_v3 - | IO_getSomeBytes_impl_v1 - | IO_putBytes_impl_v3 - | IO_systemTime_impl_v3 - | IO_systemTimeMicroseconds_v1 - | Clock_internals_monotonic_v1 - | Clock_internals_realtime_v1 - | Clock_internals_processCPUTime_v1 - | Clock_internals_threadCPUTime_v1 - | Clock_internals_sec_v1 - | Clock_internals_nsec_v1 - | Clock_internals_systemTimeZone_v1 - | IO_getTempDirectory_impl_v3 - | IO_createTempDirectory_impl_v3 - | IO_getCurrentDirectory_impl_v3 - | IO_setCurrentDirectory_impl_v3 - | IO_fileExists_impl_v3 - | IO_getEnv_impl_v1 - | IO_getArgs_impl_v1 - | IO_isDirectory_impl_v3 - | IO_createDirectory_impl_v3 - | IO_removeDirectory_impl_v3 - | IO_renameDirectory_impl_v3 - | IO_directoryContents_impl_v3 - | IO_removeFile_impl_v3 - | IO_renameFile_impl_v3 - | IO_getFileTimestamp_impl_v3 - | IO_getFileSize_impl_v3 - | IO_serverSocket_impl_v3 - | Socket_toText - | Handle_toText - | ThreadId_toText - | IO_socketPort_impl_v3 - | IO_listen_impl_v3 - | IO_clientSocket_impl_v3 - | IO_closeSocket_impl_v3 - | IO_socketAccept_impl_v3 - | IO_socketSend_impl_v3 - | IO_socketReceive_impl_v3 - | IO_kill_impl_v3 - | IO_delay_impl_v3 - | IO_stdHandle - | IO_process_call - | IO_process_start - | IO_process_kill - | IO_process_wait - | IO_process_exitCode - | MVar_new - | MVar_newEmpty_v2 - | MVar_take_impl_v3 - | MVar_tryTake - | MVar_put_impl_v3 - | MVar_tryPut_impl_v3 - | MVar_swap_impl_v3 - | MVar_isEmpty - | MVar_read_impl_v3 - | MVar_tryRead_impl_v3 - | Char_toText - | Text_repeat - | Text_reverse - | Text_toUppercase - | Text_toLowercase - | Text_toUtf8 - | Text_fromUtf8_impl_v3 - | Tls_ClientConfig_default - | Tls_ServerConfig_default - | Tls_ClientConfig_certificates_set - | Tls_ServerConfig_certificates_set - | TVar_new - | TVar_read - | TVar_write - | TVar_newIO - | TVar_readIO - | TVar_swap - | STM_retry - | Promise_new - | Promise_read - | Promise_tryRead - | Promise_write - | Tls_newClient_impl_v3 - | Tls_newServer_impl_v3 - | Tls_handshake_impl_v3 - | Tls_send_impl_v3 - | Tls_decodeCert_impl_v3 - | Tls_encodeCert - | Tls_decodePrivateKey - | Tls_encodePrivateKey - | Tls_receive_impl_v3 - | Tls_terminate_impl_v3 - | Code_validateLinks - | Code_dependencies - | Code_serialize - | Code_deserialize - | Code_display - | Value_dependencies - | Value_serialize - | Value_deserialize - | Crypto_HashAlgorithm_Sha3_512 - | Crypto_HashAlgorithm_Sha3_256 - | Crypto_HashAlgorithm_Sha2_512 - | Crypto_HashAlgorithm_Sha2_256 - | Crypto_HashAlgorithm_Sha1 - | Crypto_HashAlgorithm_Blake2b_512 - | Crypto_HashAlgorithm_Blake2b_256 - | Crypto_HashAlgorithm_Blake2s_256 - | Crypto_HashAlgorithm_Md5 - | Crypto_hashBytes - | Crypto_hmacBytes - | Crypto_hash - | Crypto_hmac - | Crypto_Ed25519_sign_impl - | Crypto_Ed25519_verify_impl - | Crypto_Rsa_sign_impl - | Crypto_Rsa_verify_impl - | Universal_murmurHash - | IO_randomBytes - | Bytes_zlib_compress - | Bytes_gzip_compress - | Bytes_zlib_decompress - | Bytes_gzip_decompress - | Bytes_toBase16 - | Bytes_toBase32 - | Bytes_toBase64 - | Bytes_toBase64UrlUnpadded - | Bytes_fromBase16 - | Bytes_fromBase32 - | Bytes_fromBase64 - | Bytes_fromBase64UrlUnpadded - | Bytes_decodeNat64be - | Bytes_decodeNat64le - | Bytes_decodeNat32be - | Bytes_decodeNat32le - | Bytes_decodeNat16be - | Bytes_decodeNat16le - | Bytes_encodeNat64be - | Bytes_encodeNat64le - | Bytes_encodeNat32be - | Bytes_encodeNat32le - | Bytes_encodeNat16be - | Bytes_encodeNat16le - | MutableArray_copyTo_force - | MutableByteArray_copyTo_force - | ImmutableArray_copyTo_force - | ImmutableArray_size - | MutableArray_size - | ImmutableByteArray_size - | MutableByteArray_size - | ImmutableByteArray_copyTo_force - | MutableArray_read - | MutableByteArray_read8 - | MutableByteArray_read16be - | MutableByteArray_read24be - | MutableByteArray_read32be - | MutableByteArray_read40be - | MutableByteArray_read64be - | MutableArray_write - | MutableByteArray_write8 - | MutableByteArray_write16be - | MutableByteArray_write32be - | MutableByteArray_write64be - | ImmutableArray_read - | ImmutableByteArray_read8 - | ImmutableByteArray_read16be - | ImmutableByteArray_read24be - | ImmutableByteArray_read32be - | ImmutableByteArray_read40be - | ImmutableByteArray_read64be - | MutableByteArray_freeze_force - | MutableArray_freeze_force - | MutableByteArray_freeze - | MutableArray_freeze - | MutableByteArray_length - | ImmutableByteArray_length - | IO_array - | IO_arrayOf - | IO_bytearray - | IO_bytearrayOf - | Scope_array - | Scope_arrayOf - | Scope_bytearray - | Scope_bytearrayOf - | Text_patterns_literal - | Text_patterns_digit - | Text_patterns_letter - | Text_patterns_space - | Text_patterns_punctuation - | Text_patterns_anyChar - | Text_patterns_eof - | Text_patterns_charRange - | Text_patterns_notCharRange - | Text_patterns_charIn - | Text_patterns_notCharIn - | Pattern_many - | Pattern_many_corrected - | Pattern_capture - | Pattern_captureAs - | Pattern_join - | Pattern_or - | Pattern_replicate - | Pattern_run - | Pattern_isMatch - | Char_Class_any - | Char_Class_not - | Char_Class_and - | Char_Class_or - | Char_Class_range - | Char_Class_anyOf - | Char_Class_alphanumeric - | Char_Class_upper - | Char_Class_lower - | Char_Class_whitespace - | Char_Class_control - | Char_Class_printable - | Char_Class_mark - | Char_Class_number - | Char_Class_punctuation - | Char_Class_symbol - | Char_Class_separator - | Char_Class_letter - | Char_Class_is - | Text_patterns_char - deriving (Show, Eq, Ord, Enum, Bounded) - type ANormal = ABTN.Term ANormalF type Cte v = CTE v (ANormal v) diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 9ce7c5db50..4b0759ad0f 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -25,6 +25,7 @@ import Unison.ABT.Normalized (Term (..)) import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Runtime.Exception +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.Serialize import Unison.Util.Text qualified as Util.Text import Unison.Var (Type (ANFBlank), Var (..)) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 261318fe54..f6e610cdf7 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -20,6 +20,7 @@ module Unison.Runtime.Builtin unitValue, natValue, builtinForeignNames, + sandboxedForeignFuncs, ) where @@ -34,6 +35,7 @@ import Unison.Prelude hiding (Text, some) import Unison.Reference import Unison.Runtime.ANF as ANF import Unison.Runtime.Builtin.Types +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol @@ -1688,7 +1690,7 @@ builtinLookup = ] ++ foreignWrappers -type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v, Data.Text.Text)) +type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v)) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1699,14 +1701,13 @@ data Sandbox = Tracked | Untracked declareForeign :: Sandbox -> - Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand name op func = do +declareForeign sand op func = do modify $ \funcs -> let code = uncurry Lambda (op func) - in (Map.insert func (sand, code, name) funcs) + in (Map.insert func (sand, code) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -1716,376 +1717,376 @@ natValue w = NatVal w declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF IO_UDP_clientSocket_impl_v1 + declareForeign Tracked arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF IO_UDP_UDPSocket_recv_impl_v1 + declareForeign Tracked argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 IO_UDP_UDPSocket_close_impl_v1 + declareForeign Tracked arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 IO_UDP_ListenSocket_close_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 + declareForeign Tracked (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF IO_UDP_serverSocket_impl_v1 + declareForeign Tracked arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 + declareForeign Tracked (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 + declareForeign Tracked argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 + declareForeign Tracked (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 + declareForeign Tracked arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF IO_openFile_impl_v3 + declareForeign Tracked argIomrToEF IO_openFile_impl_v3 - declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 IO_closeFile_impl_v3 - declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool IO_isFileEOF_impl_v3 - declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool IO_isFileOpen_impl_v3 - declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool IO_getEcho_impl_v1 - declareForeign Tracked "IO.ready.impl.v1" argToEFBool IO_ready_impl_v1 - declareForeign Tracked "IO.getChar.impl.v1" argToEFChar IO_getChar_impl_v1 - declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool IO_isSeekable_impl_v3 + declareForeign Tracked argToEF0 IO_closeFile_impl_v3 + declareForeign Tracked argToEFBool IO_isFileEOF_impl_v3 + declareForeign Tracked argToEFBool IO_isFileOpen_impl_v3 + declareForeign Tracked argToEFBool IO_getEcho_impl_v1 + declareForeign Tracked argToEFBool IO_ready_impl_v1 + declareForeign Tracked argToEFChar IO_getChar_impl_v1 + declareForeign Tracked argToEFBool IO_isSeekable_impl_v3 - declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle IO_seekHandle_impl_v3 + declareForeign Tracked seek'handle IO_seekHandle_impl_v3 - declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat IO_handlePosition_impl_v3 + declareForeign Tracked argToEFNat IO_handlePosition_impl_v3 - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering IO_getBuffering_impl_v3 + declareForeign Tracked get'buffering IO_getBuffering_impl_v3 - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering IO_setBuffering_impl_v3 + declareForeign Tracked set'buffering IO_setBuffering_impl_v3 - declareForeign Tracked "IO.setEcho.impl.v1" set'echo IO_setEcho_impl_v1 + declareForeign Tracked set'echo IO_setEcho_impl_v1 - declareForeign Tracked "IO.getLine.impl.v1" argToEF IO_getLine_impl_v1 + declareForeign Tracked argToEF IO_getLine_impl_v1 - declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF IO_getBytes_impl_v3 - declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF IO_getSomeBytes_impl_v1 - declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 IO_putBytes_impl_v3 - declareForeign Tracked "IO.systemTime.impl.v3" unitToEF IO_systemTime_impl_v3 + declareForeign Tracked arg2ToEF IO_getBytes_impl_v3 + declareForeign Tracked arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign Tracked arg2ToEF0 IO_putBytes_impl_v3 + declareForeign Tracked unitToEF IO_systemTime_impl_v3 - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR IO_systemTimeMicroseconds_v1 + declareForeign Tracked unitToR IO_systemTimeMicroseconds_v1 - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF Clock_internals_monotonic_v1 + declareForeign Tracked unitToEF Clock_internals_monotonic_v1 - declareForeign Tracked "Clock.internals.realtime.v1" unitToEF Clock_internals_realtime_v1 + declareForeign Tracked unitToEF Clock_internals_realtime_v1 - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF Clock_internals_processCPUTime_v1 + declareForeign Tracked unitToEF Clock_internals_processCPUTime_v1 - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF Clock_internals_threadCPUTime_v1 + declareForeign Tracked unitToEF Clock_internals_threadCPUTime_v1 - declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) Clock_internals_sec_v1 + declareForeign Tracked (argNDirect 1) Clock_internals_sec_v1 -- A TimeSpec that comes from getTime never has negative nanos, -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) Clock_internals_nsec_v1 + declareForeign Tracked (argNDirect 1) Clock_internals_nsec_v1 - declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone Clock_internals_systemTimeZone_v1 + declareForeign Tracked time'zone Clock_internals_systemTimeZone_v1 - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF IO_getTempDirectory_impl_v3 + declareForeign Tracked unitToEF IO_getTempDirectory_impl_v3 - declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF IO_createTempDirectory_impl_v3 + declareForeign Tracked argToEF IO_createTempDirectory_impl_v3 - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF IO_getCurrentDirectory_impl_v3 + declareForeign Tracked unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 IO_setCurrentDirectory_impl_v3 + declareForeign Tracked argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool IO_fileExists_impl_v3 + declareForeign Tracked argToEFBool IO_fileExists_impl_v3 - declareForeign Tracked "IO.getEnv.impl.v1" argToEF IO_getEnv_impl_v1 + declareForeign Tracked argToEF IO_getEnv_impl_v1 - declareForeign Tracked "IO.getArgs.impl.v1" unitToEF IO_getArgs_impl_v1 + declareForeign Tracked unitToEF IO_getArgs_impl_v1 - declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool IO_isDirectory_impl_v3 + declareForeign Tracked argToEFBool IO_isDirectory_impl_v3 - declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 IO_createDirectory_impl_v3 + declareForeign Tracked argToEF0 IO_createDirectory_impl_v3 - declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 IO_removeDirectory_impl_v3 + declareForeign Tracked argToEF0 IO_removeDirectory_impl_v3 - declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 IO_renameDirectory_impl_v3 + declareForeign Tracked arg2ToEF0 IO_renameDirectory_impl_v3 - declareForeign Tracked "IO.directoryContents.impl.v3" argToEF IO_directoryContents_impl_v3 + declareForeign Tracked argToEF IO_directoryContents_impl_v3 - declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 IO_removeFile_impl_v3 + declareForeign Tracked argToEF0 IO_removeFile_impl_v3 - declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 IO_renameFile_impl_v3 + declareForeign Tracked arg2ToEF0 IO_renameFile_impl_v3 - declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat IO_getFileTimestamp_impl_v3 + declareForeign Tracked argToEFNat IO_getFileTimestamp_impl_v3 - declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat IO_getFileSize_impl_v3 + declareForeign Tracked argToEFNat IO_getFileSize_impl_v3 - declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF IO_serverSocket_impl_v3 + declareForeign Tracked maybeToEF IO_serverSocket_impl_v3 - declareForeign Tracked "Socket.toText" (argNDirect 1) Socket_toText + declareForeign Tracked (argNDirect 1) Socket_toText - declareForeign Tracked "Handle.toText" (argNDirect 1) Handle_toText + declareForeign Tracked (argNDirect 1) Handle_toText - declareForeign Tracked "ThreadId.toText" (argNDirect 1) ThreadId_toText + declareForeign Tracked (argNDirect 1) ThreadId_toText - declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat IO_socketPort_impl_v3 + declareForeign Tracked argToEFNat IO_socketPort_impl_v3 - declareForeign Tracked "IO.listen.impl.v3" argToEF0 IO_listen_impl_v3 + declareForeign Tracked argToEF0 IO_listen_impl_v3 - declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF IO_clientSocket_impl_v3 + declareForeign Tracked arg2ToEF IO_clientSocket_impl_v3 - declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 IO_closeSocket_impl_v3 + declareForeign Tracked argToEF0 IO_closeSocket_impl_v3 - declareForeign Tracked "IO.socketAccept.impl.v3" argToEF IO_socketAccept_impl_v3 + declareForeign Tracked argToEF IO_socketAccept_impl_v3 - declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 IO_socketSend_impl_v3 + declareForeign Tracked arg2ToEF0 IO_socketSend_impl_v3 - declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF IO_socketReceive_impl_v3 + declareForeign Tracked arg2ToEF IO_socketReceive_impl_v3 - declareForeign Tracked "IO.kill.impl.v3" argToEF0 IO_kill_impl_v3 + declareForeign Tracked argToEF0 IO_kill_impl_v3 - declareForeign Tracked "IO.delay.impl.v3" argToEFUnit IO_delay_impl_v3 + declareForeign Tracked argToEFUnit IO_delay_impl_v3 - declareForeign Tracked "IO.stdHandle" standard'handle IO_stdHandle + declareForeign Tracked standard'handle IO_stdHandle - declareForeign Tracked "IO.process.call" (argNDirect 2) IO_process_call + declareForeign Tracked (argNDirect 2) IO_process_call - declareForeign Tracked "IO.process.start" start'process IO_process_start + declareForeign Tracked start'process IO_process_start - declareForeign Tracked "IO.process.kill" argToUnit IO_process_kill + declareForeign Tracked argToUnit IO_process_kill - declareForeign Tracked "IO.process.wait" (argNDirect 1) IO_process_wait + declareForeign Tracked (argNDirect 1) IO_process_wait - declareForeign Tracked "IO.process.exitCode" argToMaybe IO_process_exitCode - declareForeign Tracked "MVar.new" (argNDirect 1) MVar_new + declareForeign Tracked argToMaybe IO_process_exitCode + declareForeign Tracked (argNDirect 1) MVar_new - declareForeign Tracked "MVar.newEmpty.v2" unitDirect MVar_newEmpty_v2 + declareForeign Tracked unitDirect MVar_newEmpty_v2 - declareForeign Tracked "MVar.take.impl.v3" argToEF MVar_take_impl_v3 + declareForeign Tracked argToEF MVar_take_impl_v3 - declareForeign Tracked "MVar.tryTake" argToMaybe MVar_tryTake + declareForeign Tracked argToMaybe MVar_tryTake - declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 MVar_put_impl_v3 + declareForeign Tracked arg2ToEF0 MVar_put_impl_v3 - declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool MVar_tryPut_impl_v3 + declareForeign Tracked arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF MVar_swap_impl_v3 + declareForeign Tracked arg2ToEF MVar_swap_impl_v3 - declareForeign Tracked "MVar.isEmpty" (argNDirect 1) MVar_isEmpty + declareForeign Tracked (argNDirect 1) MVar_isEmpty - declareForeign Tracked "MVar.read.impl.v3" argToEF MVar_read_impl_v3 + declareForeign Tracked argToEF MVar_read_impl_v3 - declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM MVar_tryRead_impl_v3 + declareForeign Tracked argToEFM MVar_tryRead_impl_v3 - declareForeign Untracked "Char.toText" (argNDirect 1) Char_toText - declareForeign Untracked "Text.repeat" (argNDirect 2) Text_repeat - declareForeign Untracked "Text.reverse" (argNDirect 1) Text_reverse - declareForeign Untracked "Text.toUppercase" (argNDirect 1) Text_toUppercase - declareForeign Untracked "Text.toLowercase" (argNDirect 1) Text_toLowercase - declareForeign Untracked "Text.toUtf8" (argNDirect 1) Text_toUtf8 - declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF Text_fromUtf8_impl_v3 - declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) Tls_ClientConfig_default - declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) Tls_ServerConfig_default - declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) Tls_ClientConfig_certificates_set + declareForeign Untracked (argNDirect 1) Char_toText + declareForeign Untracked (argNDirect 2) Text_repeat + declareForeign Untracked (argNDirect 1) Text_reverse + declareForeign Untracked (argNDirect 1) Text_toUppercase + declareForeign Untracked (argNDirect 1) Text_toLowercase + declareForeign Untracked (argNDirect 1) Text_toUtf8 + declareForeign Untracked argToEF Text_fromUtf8_impl_v3 + declareForeign Tracked (argNDirect 2) Tls_ClientConfig_default + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_default + declareForeign Tracked (argNDirect 2) Tls_ClientConfig_certificates_set - declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) Tls_ServerConfig_certificates_set + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign Tracked "TVar.new" (argNDirect 1) TVar_new + declareForeign Tracked (argNDirect 1) TVar_new - declareForeign Tracked "TVar.read" (argNDirect 1) TVar_read - declareForeign Tracked "TVar.write" arg2To0 TVar_write - declareForeign Tracked "TVar.newIO" (argNDirect 1) TVar_newIO + declareForeign Tracked (argNDirect 1) TVar_read + declareForeign Tracked arg2To0 TVar_write + declareForeign Tracked (argNDirect 1) TVar_newIO - declareForeign Tracked "TVar.readIO" (argNDirect 1) TVar_readIO - declareForeign Tracked "TVar.swap" (argNDirect 2) TVar_swap - declareForeign Tracked "STM.retry" unitDirect STM_retry - declareForeign Tracked "Promise.new" unitDirect Promise_new + declareForeign Tracked (argNDirect 1) TVar_readIO + declareForeign Tracked (argNDirect 2) TVar_swap + declareForeign Tracked unitDirect STM_retry + declareForeign Tracked unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" (argNDirect 1) Promise_read - declareForeign Tracked "Promise.tryRead" argToMaybe Promise_tryRead - - declareForeign Tracked "Promise.write" (argNDirect 2) Promise_write - declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF Tls_newClient_impl_v3 - declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF Tls_newServer_impl_v3 - declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 Tls_handshake_impl_v3 - declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 Tls_send_impl_v3 - declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF Tls_decodeCert_impl_v3 - - declareForeign Tracked "Tls.encodeCert" (argNDirect 1) Tls_encodeCert - - declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) Tls_decodePrivateKey - declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) Tls_encodePrivateKey - - declareForeign Tracked "Tls.receive.impl.v3" argToEF Tls_receive_impl_v3 - - declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 Tls_terminate_impl_v3 - declareForeign Untracked "Code.validateLinks" argToExnE Code_validateLinks - declareForeign Untracked "Code.dependencies" (argNDirect 1) Code_dependencies - declareForeign Untracked "Code.serialize" (argNDirect 1) Code_serialize - declareForeign Untracked "Code.deserialize" argToEither Code_deserialize - declareForeign Untracked "Code.display" (argNDirect 2) Code_display - declareForeign Untracked "Value.dependencies" (argNDirect 1) Value_dependencies - declareForeign Untracked "Value.serialize" (argNDirect 1) Value_serialize - declareForeign Untracked "Value.deserialize" argToEither Value_deserialize + declareForeign Tracked (argNDirect 1) Promise_read + declareForeign Tracked argToMaybe Promise_tryRead + + declareForeign Tracked (argNDirect 2) Promise_write + declareForeign Tracked arg2ToEF Tls_newClient_impl_v3 + declareForeign Tracked arg2ToEF Tls_newServer_impl_v3 + declareForeign Tracked argToEF0 Tls_handshake_impl_v3 + declareForeign Tracked arg2ToEF0 Tls_send_impl_v3 + declareForeign Tracked argToEF Tls_decodeCert_impl_v3 + + declareForeign Tracked (argNDirect 1) Tls_encodeCert + + declareForeign Tracked (argNDirect 1) Tls_decodePrivateKey + declareForeign Tracked (argNDirect 1) Tls_encodePrivateKey + + declareForeign Tracked argToEF Tls_receive_impl_v3 + + declareForeign Tracked argToEF0 Tls_terminate_impl_v3 + declareForeign Untracked argToExnE Code_validateLinks + declareForeign Untracked (argNDirect 1) Code_dependencies + declareForeign Untracked (argNDirect 1) Code_serialize + declareForeign Untracked argToEither Code_deserialize + declareForeign Untracked (argNDirect 2) Code_display + declareForeign Untracked (argNDirect 1) Value_dependencies + declareForeign Untracked (argNDirect 1) Value_serialize + declareForeign Untracked argToEither Value_deserialize -- Hashing functions - declareForeign Untracked "crypto.HashAlgorithm.Sha3_512" direct Crypto_HashAlgorithm_Sha3_512 - declareForeign Untracked "crypto.HashAlgorithm.Sha3_256" direct Crypto_HashAlgorithm_Sha3_256 - declareForeign Untracked "crypto.HashAlgorithm.Sha2_512" direct Crypto_HashAlgorithm_Sha2_512 - declareForeign Untracked "crypto.HashAlgorithm.Sha2_256" direct Crypto_HashAlgorithm_Sha2_256 - declareForeign Untracked "crypto.HashAlgorithm.Sha1" direct Crypto_HashAlgorithm_Sha1 - declareForeign Untracked "crypto.HashAlgorithm.Blake2b_512" direct Crypto_HashAlgorithm_Blake2b_512 - declareForeign Untracked "crypto.HashAlgorithm.Blake2b_256" direct Crypto_HashAlgorithm_Blake2b_256 - declareForeign Untracked "crypto.HashAlgorithm.Blake2s_256" direct Crypto_HashAlgorithm_Blake2s_256 - declareForeign Untracked "crypto.HashAlgorithm.Md5" direct Crypto_HashAlgorithm_Md5 - - declareForeign Untracked "crypto.hashBytes" (argNDirect 2) Crypto_hashBytes - declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) Crypto_hmacBytes - - declareForeign Untracked "crypto.hash" crypto'hash Crypto_hash - declareForeign Untracked "crypto.hmac" crypto'hmac Crypto_hmac - declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF Crypto_Ed25519_sign_impl - - declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool Crypto_Ed25519_verify_impl - - declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF Crypto_Rsa_sign_impl - - declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool Crypto_Rsa_verify_impl - - declareForeign Untracked "Universal.murmurHash" murmur'hash Universal_murmurHash - declareForeign Tracked "IO.randomBytes" (argNDirect 1) IO_randomBytes - declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) Bytes_zlib_compress - declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) Bytes_gzip_compress - declareForeign Untracked "Bytes.zlib.decompress" argToEither Bytes_zlib_decompress - declareForeign Untracked "Bytes.gzip.decompress" argToEither Bytes_gzip_decompress - - declareForeign Untracked "Bytes.toBase16" (argNDirect 1) Bytes_toBase16 - declareForeign Untracked "Bytes.toBase32" (argNDirect 1) Bytes_toBase32 - declareForeign Untracked "Bytes.toBase64" (argNDirect 1) Bytes_toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) Bytes_toBase64UrlUnpadded - - declareForeign Untracked "Bytes.fromBase16" argToEither Bytes_fromBase16 - declareForeign Untracked "Bytes.fromBase32" argToEither Bytes_fromBase32 - declareForeign Untracked "Bytes.fromBase64" argToEither Bytes_fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither Bytes_fromBase64UrlUnpadded - - declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup Bytes_decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup Bytes_decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup Bytes_decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup Bytes_decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup Bytes_decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup Bytes_decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) Bytes_encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) Bytes_encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) Bytes_encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) Bytes_encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) Bytes_encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) Bytes_encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit MutableArray_copyTo_force - - declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit MutableByteArray_copyTo_force - - declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit ImmutableArray_copyTo_force - - declareForeign Untracked "ImmutableArray.size" (argNDirect 1) ImmutableArray_size - declareForeign Untracked "MutableArray.size" (argNDirect 1) MutableArray_size - declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) ImmutableByteArray_size - declareForeign Untracked "MutableByteArray.size" (argNDirect 1) MutableByteArray_size - - declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit ImmutableByteArray_copyTo_force - - declareForeign Untracked "MutableArray.read" arg2ToExn MutableArray_read - declareForeign Untracked "MutableByteArray.read8" arg2ToExn MutableByteArray_read8 - declareForeign Untracked "MutableByteArray.read16be" arg2ToExn MutableByteArray_read16be - declareForeign Untracked "MutableByteArray.read24be" arg2ToExn MutableByteArray_read24be - declareForeign Untracked "MutableByteArray.read32be" arg2ToExn MutableByteArray_read32be - declareForeign Untracked "MutableByteArray.read40be" arg2ToExn MutableByteArray_read40be - declareForeign Untracked "MutableByteArray.read64be" arg2ToExn MutableByteArray_read64be - - declareForeign Untracked "MutableArray.write" arg3ToExnUnit MutableArray_write - declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit MutableByteArray_write8 - declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit MutableByteArray_write16be - declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit MutableByteArray_write32be - declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit MutableByteArray_write64be - - declareForeign Untracked "ImmutableArray.read" arg2ToExn ImmutableArray_read - declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn ImmutableByteArray_read8 - declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn ImmutableByteArray_read16be - declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn ImmutableByteArray_read24be - declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn ImmutableByteArray_read32be - declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn ImmutableByteArray_read40be - declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn ImmutableByteArray_read64be - - declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) MutableByteArray_freeze_force - declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) MutableArray_freeze_force - - declareForeign Untracked "MutableByteArray.freeze" arg3ToExn MutableByteArray_freeze - declareForeign Untracked "MutableArray.freeze" arg3ToExn MutableArray_freeze - - declareForeign Untracked "MutableByteArray.length" (argNDirect 1) MutableByteArray_length - - declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) ImmutableByteArray_length - - declareForeign Tracked "IO.array" (argNDirect 1) IO_array - declareForeign Tracked "IO.arrayOf" (argNDirect 2) IO_arrayOf - declareForeign Tracked "IO.bytearray" (argNDirect 1) IO_bytearray - declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) IO_bytearrayOf - - declareForeign Untracked "Scope.array" (argNDirect 1) Scope_array - declareForeign Untracked "Scope.arrayOf" (argNDirect 2) Scope_arrayOf - declareForeign Untracked "Scope.bytearray" (argNDirect 1) Scope_bytearray - declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) Scope_bytearrayOf - - declareForeign Untracked "Text.patterns.literal" (argNDirect 1) Text_patterns_literal - declareForeign Untracked "Text.patterns.digit" direct Text_patterns_digit - declareForeign Untracked "Text.patterns.letter" direct Text_patterns_letter - declareForeign Untracked "Text.patterns.space" direct Text_patterns_space - declareForeign Untracked "Text.patterns.punctuation" direct Text_patterns_punctuation - declareForeign Untracked "Text.patterns.anyChar" direct Text_patterns_anyChar - declareForeign Untracked "Text.patterns.eof" direct Text_patterns_eof - declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) Text_patterns_charRange - declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) Text_patterns_notCharRange - declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) Text_patterns_charIn - declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) Text_patterns_notCharIn - declareForeign Untracked "Pattern.many" (argNDirect 1) Pattern_many - declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) Pattern_many_corrected - declareForeign Untracked "Pattern.capture" (argNDirect 1) Pattern_capture - declareForeign Untracked "Pattern.captureAs" (argNDirect 2) Pattern_captureAs - declareForeign Untracked "Pattern.join" (argNDirect 1) Pattern_join - declareForeign Untracked "Pattern.or" (argNDirect 2) Pattern_or - declareForeign Untracked "Pattern.replicate" (argNDirect 3) Pattern_replicate - - declareForeign Untracked "Pattern.run" arg2ToMaybeTup Pattern_run - - declareForeign Untracked "Pattern.isMatch" (argNDirect 2) Pattern_isMatch - - declareForeign Untracked "Char.Class.any" direct Char_Class_any - declareForeign Untracked "Char.Class.not" (argNDirect 1) Char_Class_not - declareForeign Untracked "Char.Class.and" (argNDirect 2) Char_Class_and - declareForeign Untracked "Char.Class.or" (argNDirect 2) Char_Class_or - declareForeign Untracked "Char.Class.range" (argNDirect 2) Char_Class_range - declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) Char_Class_anyOf - declareForeign Untracked "Char.Class.alphanumeric" direct Char_Class_alphanumeric - declareForeign Untracked "Char.Class.upper" direct Char_Class_upper - declareForeign Untracked "Char.Class.lower" direct Char_Class_lower - declareForeign Untracked "Char.Class.whitespace" direct Char_Class_whitespace - declareForeign Untracked "Char.Class.control" direct Char_Class_control - declareForeign Untracked "Char.Class.printable" direct Char_Class_printable - declareForeign Untracked "Char.Class.mark" direct Char_Class_mark - declareForeign Untracked "Char.Class.number" direct Char_Class_number - declareForeign Untracked "Char.Class.punctuation" direct Char_Class_punctuation - declareForeign Untracked "Char.Class.symbol" direct Char_Class_symbol - declareForeign Untracked "Char.Class.separator" direct Char_Class_separator - declareForeign Untracked "Char.Class.letter" direct Char_Class_letter - declareForeign Untracked "Char.Class.is" (argNDirect 2) Char_Class_is - declareForeign Untracked "Text.patterns.char" (argNDirect 1) Text_patterns_char - -foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol, Data.Text.Text)) + declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha1 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Md5 + + declareForeign Untracked (argNDirect 2) Crypto_hashBytes + declareForeign Untracked (argNDirect 3) Crypto_hmacBytes + + declareForeign Untracked crypto'hash Crypto_hash + declareForeign Untracked crypto'hmac Crypto_hmac + declareForeign Untracked arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign Untracked arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign Untracked arg2ToEF Crypto_Rsa_sign_impl + + declareForeign Untracked arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign Untracked murmur'hash Universal_murmurHash + declareForeign Tracked (argNDirect 1) IO_randomBytes + declareForeign Untracked (argNDirect 1) Bytes_zlib_compress + declareForeign Untracked (argNDirect 1) Bytes_gzip_compress + declareForeign Untracked argToEither Bytes_zlib_decompress + declareForeign Untracked argToEither Bytes_gzip_decompress + + declareForeign Untracked (argNDirect 1) Bytes_toBase16 + declareForeign Untracked (argNDirect 1) Bytes_toBase32 + declareForeign Untracked (argNDirect 1) Bytes_toBase64 + declareForeign Untracked (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign Untracked argToEither Bytes_fromBase16 + declareForeign Untracked argToEither Bytes_fromBase32 + declareForeign Untracked argToEither Bytes_fromBase64 + declareForeign Untracked argToEither Bytes_fromBase64UrlUnpadded + + declareForeign Untracked argToMaybeNTup Bytes_decodeNat64be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat64le + declareForeign Untracked argToMaybeNTup Bytes_decodeNat32be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat32le + declareForeign Untracked argToMaybeNTup Bytes_decodeNat16be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat16le + + declareForeign Untracked (argNDirect 1) Bytes_encodeNat64be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat64le + declareForeign Untracked (argNDirect 1) Bytes_encodeNat32be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat32le + declareForeign Untracked (argNDirect 1) Bytes_encodeNat16be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat16le + + declareForeign Untracked arg5ToExnUnit MutableArray_copyTo_force + + declareForeign Untracked arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign Untracked arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign Untracked (argNDirect 1) ImmutableArray_size + declareForeign Untracked (argNDirect 1) MutableArray_size + declareForeign Untracked (argNDirect 1) ImmutableByteArray_size + declareForeign Untracked (argNDirect 1) MutableByteArray_size + + declareForeign Untracked arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign Untracked arg2ToExn MutableArray_read + declareForeign Untracked arg2ToExn MutableByteArray_read8 + declareForeign Untracked arg2ToExn MutableByteArray_read16be + declareForeign Untracked arg2ToExn MutableByteArray_read24be + declareForeign Untracked arg2ToExn MutableByteArray_read32be + declareForeign Untracked arg2ToExn MutableByteArray_read40be + declareForeign Untracked arg2ToExn MutableByteArray_read64be + + declareForeign Untracked arg3ToExnUnit MutableArray_write + declareForeign Untracked arg3ToExnUnit MutableByteArray_write8 + declareForeign Untracked arg3ToExnUnit MutableByteArray_write16be + declareForeign Untracked arg3ToExnUnit MutableByteArray_write32be + declareForeign Untracked arg3ToExnUnit MutableByteArray_write64be + + declareForeign Untracked arg2ToExn ImmutableArray_read + declareForeign Untracked arg2ToExn ImmutableByteArray_read8 + declareForeign Untracked arg2ToExn ImmutableByteArray_read16be + declareForeign Untracked arg2ToExn ImmutableByteArray_read24be + declareForeign Untracked arg2ToExn ImmutableByteArray_read32be + declareForeign Untracked arg2ToExn ImmutableByteArray_read40be + declareForeign Untracked arg2ToExn ImmutableByteArray_read64be + + declareForeign Untracked (argNDirect 1) MutableByteArray_freeze_force + declareForeign Untracked (argNDirect 1) MutableArray_freeze_force + + declareForeign Untracked arg3ToExn MutableByteArray_freeze + declareForeign Untracked arg3ToExn MutableArray_freeze + + declareForeign Untracked (argNDirect 1) MutableByteArray_length + + declareForeign Untracked (argNDirect 1) ImmutableByteArray_length + + declareForeign Tracked (argNDirect 1) IO_array + declareForeign Tracked (argNDirect 2) IO_arrayOf + declareForeign Tracked (argNDirect 1) IO_bytearray + declareForeign Tracked (argNDirect 2) IO_bytearrayOf + + declareForeign Untracked (argNDirect 1) Scope_array + declareForeign Untracked (argNDirect 2) Scope_arrayOf + declareForeign Untracked (argNDirect 1) Scope_bytearray + declareForeign Untracked (argNDirect 2) Scope_bytearrayOf + + declareForeign Untracked (argNDirect 1) Text_patterns_literal + declareForeign Untracked direct Text_patterns_digit + declareForeign Untracked direct Text_patterns_letter + declareForeign Untracked direct Text_patterns_space + declareForeign Untracked direct Text_patterns_punctuation + declareForeign Untracked direct Text_patterns_anyChar + declareForeign Untracked direct Text_patterns_eof + declareForeign Untracked (argNDirect 2) Text_patterns_charRange + declareForeign Untracked (argNDirect 2) Text_patterns_notCharRange + declareForeign Untracked (argNDirect 1) Text_patterns_charIn + declareForeign Untracked (argNDirect 1) Text_patterns_notCharIn + declareForeign Untracked (argNDirect 1) Pattern_many + declareForeign Untracked (argNDirect 1) Pattern_many_corrected + declareForeign Untracked (argNDirect 1) Pattern_capture + declareForeign Untracked (argNDirect 2) Pattern_captureAs + declareForeign Untracked (argNDirect 1) Pattern_join + declareForeign Untracked (argNDirect 2) Pattern_or + declareForeign Untracked (argNDirect 3) Pattern_replicate + + declareForeign Untracked arg2ToMaybeTup Pattern_run + + declareForeign Untracked (argNDirect 2) Pattern_isMatch + + declareForeign Untracked direct Char_Class_any + declareForeign Untracked (argNDirect 1) Char_Class_not + declareForeign Untracked (argNDirect 2) Char_Class_and + declareForeign Untracked (argNDirect 2) Char_Class_or + declareForeign Untracked (argNDirect 2) Char_Class_range + declareForeign Untracked (argNDirect 1) Char_Class_anyOf + declareForeign Untracked direct Char_Class_alphanumeric + declareForeign Untracked direct Char_Class_upper + declareForeign Untracked direct Char_Class_lower + declareForeign Untracked direct Char_Class_whitespace + declareForeign Untracked direct Char_Class_control + declareForeign Untracked direct Char_Class_printable + declareForeign Untracked direct Char_Class_mark + declareForeign Untracked direct Char_Class_number + declareForeign Untracked direct Char_Class_punctuation + declareForeign Untracked direct Char_Class_symbol + declareForeign Untracked direct Char_Class_separator + declareForeign Untracked direct Char_Class_letter + declareForeign Untracked (argNDirect 2) Char_Class_is + declareForeign Untracked (argNDirect 1) Text_patterns_char + +foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol)) foreignDeclResults = execState declareForeigns mempty foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] foreignWrappers = - Map.elems foreignDeclResults - <&> \(sand, code, name) -> (name, (sand, code)) + Map.toList foreignDeclResults + <&> \(ff, (sand, code)) -> (foreignFuncBuiltinName ff, (sand, code)) numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -2099,8 +2100,12 @@ builtinTermBackref :: EnumMap Word64 Reference builtinTermBackref = mapFromList . zip [1 ..] . Map.keys $ builtinLookup -builtinForeignNames :: Map ANF.ForeignFunc Data.Text.Text -builtinForeignNames = foreignDeclResults <&> \(_, _, n) -> n +builtinForeignNames :: Map ForeignFunc Data.Text.Text +builtinForeignNames = + foreignDeclResults + & Map.keys + & map (\f -> (f, foreignFuncBuiltinName f)) + & Map.fromList -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base @@ -2121,3 +2126,8 @@ builtinArities = builtinInlineInfo :: Map Reference (Int, ANormal Symbol) builtinInlineInfo = ANF.buildInlineMap $ fmap (Rec [] . snd) builtinLookup + +sandboxedForeignFuncs :: Set ForeignFunc +sandboxedForeignFuncs = + Map.keysSet $ + Map.filter (\(sb, _) -> sb == Tracked) foreignDeclResults diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs new file mode 100644 index 0000000000..97796223e9 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs @@ -0,0 +1,506 @@ +module Unison.Runtime.Foreign.Function.Type + ( ForeignFunc (..), + foreignFuncBuiltinName, + ) +where + +import Data.Text (Text) + +-- | Enum representing every foreign call. +data ForeignFunc + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + +foreignFuncBuiltinName :: ForeignFunc -> Text +foreignFuncBuiltinName = \case + IO_UDP_clientSocket_impl_v1 -> "IO.UDP.clientSocket.impl.v1" + IO_UDP_UDPSocket_recv_impl_v1 -> "IO.UDP.UDPSocket.recv.impl.v1" + IO_UDP_UDPSocket_send_impl_v1 -> "IO.UDP.UDPSocket.send.impl.v1" + IO_UDP_UDPSocket_close_impl_v1 -> "IO.UDP.UDPSocket.close.impl.v1" + IO_UDP_ListenSocket_close_impl_v1 -> "IO.UDP.ListenSocket.close.impl.v1" + IO_UDP_UDPSocket_toText_impl_v1 -> "IO.UDP.UDPSocket.toText.impl.v1" + IO_UDP_serverSocket_impl_v1 -> "IO.UDP.serverSocket.impl.v1" + IO_UDP_ListenSocket_toText_impl_v1 -> "IO.UDP.ListenSocket.toText.impl.v1" + IO_UDP_ListenSocket_recvFrom_impl_v1 -> "IO.UDP.ListenSocket.recvFrom.impl.v1" + IO_UDP_ClientSockAddr_toText_v1 -> "IO.UDP.ClientSockAddr.toText.v1" + IO_UDP_ListenSocket_sendTo_impl_v1 -> "IO.UDP.ListenSocket.sendTo.impl.v1" + IO_openFile_impl_v3 -> "IO.openFile.impl.v3" + IO_closeFile_impl_v3 -> "IO.closeFile.impl.v3" + IO_isFileEOF_impl_v3 -> "IO.isFileEOF.impl.v3" + IO_isFileOpen_impl_v3 -> "IO.isFileOpen.impl.v3" + IO_getEcho_impl_v1 -> "IO.getEcho.impl.v1" + IO_ready_impl_v1 -> "IO.ready.impl.v1" + IO_getChar_impl_v1 -> "IO.getChar.impl.v1" + IO_isSeekable_impl_v3 -> "IO.isSeekable.impl.v3" + IO_seekHandle_impl_v3 -> "IO.seekHandle.impl.v3" + IO_handlePosition_impl_v3 -> "IO.handlePosition.impl.v3" + IO_getBuffering_impl_v3 -> "IO.getBuffering.impl.v3" + IO_setBuffering_impl_v3 -> "IO.setBuffering.impl.v3" + IO_setEcho_impl_v1 -> "IO.setEcho.impl.v1" + IO_getLine_impl_v1 -> "IO.getLine.impl.v1" + IO_getBytes_impl_v3 -> "IO.getBytes.impl.v3" + IO_getSomeBytes_impl_v1 -> "IO.getSomeBytes.impl.v1" + IO_putBytes_impl_v3 -> "IO.putBytes.impl.v3" + IO_systemTime_impl_v3 -> "IO.systemTime.impl.v3" + IO_systemTimeMicroseconds_v1 -> "IO.systemTimeMicroseconds.v1" + Clock_internals_monotonic_v1 -> "Clock.internals.monotonic.v1" + Clock_internals_realtime_v1 -> "Clock.internals.realtime.v1" + Clock_internals_processCPUTime_v1 -> "Clock.internals.processCPUTime.v1" + Clock_internals_threadCPUTime_v1 -> "Clock.internals.threadCPUTime.v1" + Clock_internals_sec_v1 -> "Clock.internals.sec.v1" + Clock_internals_nsec_v1 -> "Clock.internals.nsec.v1" + Clock_internals_systemTimeZone_v1 -> "Clock.internals.systemTimeZone.v1" + IO_getTempDirectory_impl_v3 -> "IO.getTempDirectory.impl.v3" + IO_createTempDirectory_impl_v3 -> "IO.createTempDirectory.impl.v3" + IO_getCurrentDirectory_impl_v3 -> "IO.getCurrentDirectory.impl.v3" + IO_setCurrentDirectory_impl_v3 -> "IO.setCurrentDirectory.impl.v3" + IO_fileExists_impl_v3 -> "IO.fileExists.impl.v3" + IO_getEnv_impl_v1 -> "IO.getEnv.impl.v1" + IO_getArgs_impl_v1 -> "IO.getArgs.impl.v1" + IO_isDirectory_impl_v3 -> "IO.isDirectory.impl.v3" + IO_createDirectory_impl_v3 -> "IO.createDirectory.impl.v3" + IO_removeDirectory_impl_v3 -> "IO.removeDirectory.impl.v3" + IO_renameDirectory_impl_v3 -> "IO.renameDirectory.impl.v3" + IO_directoryContents_impl_v3 -> "IO.directoryContents.impl.v3" + IO_removeFile_impl_v3 -> "IO.removeFile.impl.v3" + IO_renameFile_impl_v3 -> "IO.renameFile.impl.v3" + IO_getFileTimestamp_impl_v3 -> "IO.getFileTimestamp.impl.v3" + IO_getFileSize_impl_v3 -> "IO.getFileSize.impl.v3" + IO_serverSocket_impl_v3 -> "IO.serverSocket.impl.v3" + Socket_toText -> "Socket.toText" + Handle_toText -> "Handle.toText" + ThreadId_toText -> "ThreadId.toText" + IO_socketPort_impl_v3 -> "IO.socketPort.impl.v3" + IO_listen_impl_v3 -> "IO.listen.impl.v3" + IO_clientSocket_impl_v3 -> "IO.clientSocket.impl.v3" + IO_closeSocket_impl_v3 -> "IO.closeSocket.impl.v3" + IO_socketAccept_impl_v3 -> "IO.socketAccept.impl.v3" + IO_socketSend_impl_v3 -> "IO.socketSend.impl.v3" + IO_socketReceive_impl_v3 -> "IO.socketReceive.impl.v3" + IO_kill_impl_v3 -> "IO.kill.impl.v3" + IO_delay_impl_v3 -> "IO.delay.impl.v3" + IO_stdHandle -> "IO.stdHandle" + IO_process_call -> "IO.process.call" + IO_process_start -> "IO.process.start" + IO_process_kill -> "IO.process.kill" + IO_process_wait -> "IO.process.wait" + IO_process_exitCode -> "IO.process.exitCode" + MVar_new -> "MVar.new" + MVar_newEmpty_v2 -> "MVar.newEmpty.v2" + MVar_take_impl_v3 -> "MVar.take.impl.v3" + MVar_tryTake -> "MVar.tryTake" + MVar_put_impl_v3 -> "MVar.put.impl.v3" + MVar_tryPut_impl_v3 -> "MVar.tryPut.impl.v3" + MVar_swap_impl_v3 -> "MVar.swap.impl.v3" + MVar_isEmpty -> "MVar.isEmpty" + MVar_read_impl_v3 -> "MVar.read.impl.v3" + MVar_tryRead_impl_v3 -> "MVar.tryRead.impl.v3" + Char_toText -> "Char.toText" + Text_repeat -> "Text.repeat" + Text_reverse -> "Text.reverse" + Text_toUppercase -> "Text.toUppercase" + Text_toLowercase -> "Text.toLowercase" + Text_toUtf8 -> "Text.toUtf8" + Text_fromUtf8_impl_v3 -> "Text.fromUtf8.impl.v3" + Tls_ClientConfig_default -> "Tls.ClientConfig.default" + Tls_ServerConfig_default -> "Tls.ServerConfig.default" + Tls_ClientConfig_certificates_set -> "Tls.ClientConfig.certificates.set" + Tls_ServerConfig_certificates_set -> "Tls.ServerConfig.certificates.set" + TVar_new -> "TVar.new" + TVar_read -> "TVar.read" + TVar_write -> "TVar.write" + TVar_newIO -> "TVar.newIO" + TVar_readIO -> "TVar.readIO" + TVar_swap -> "TVar.swap" + STM_retry -> "STM.retry" + Promise_new -> "Promise.new" + Promise_read -> "Promise.read" + Promise_tryRead -> "Promise.tryRead" + Promise_write -> "Promise.write" + Tls_newClient_impl_v3 -> "Tls.newClient.impl.v3" + Tls_newServer_impl_v3 -> "Tls.newServer.impl.v3" + Tls_handshake_impl_v3 -> "Tls.handshake.impl.v3" + Tls_send_impl_v3 -> "Tls.send.impl.v3" + Tls_decodeCert_impl_v3 -> "Tls.decodeCert.impl.v3" + Tls_encodeCert -> "Tls.encodeCert" + Tls_decodePrivateKey -> "Tls.decodePrivateKey" + Tls_encodePrivateKey -> "Tls.encodePrivateKey" + Tls_receive_impl_v3 -> "Tls.receive.impl.v3" + Tls_terminate_impl_v3 -> "Tls.terminate.impl.v3" + Code_validateLinks -> "Code.validateLinks" + Code_dependencies -> "Code.dependencies" + Code_serialize -> "Code.serialize" + Code_deserialize -> "Code.deserialize" + Code_display -> "Code.display" + Value_dependencies -> "Value.dependencies" + Value_serialize -> "Value.serialize" + Value_deserialize -> "Value.deserialize" + Crypto_HashAlgorithm_Sha3_512 -> "crypto.HashAlgorithm.Sha3_512" + Crypto_HashAlgorithm_Sha3_256 -> "crypto.HashAlgorithm.Sha3_256" + Crypto_HashAlgorithm_Sha2_512 -> "crypto.HashAlgorithm.Sha2_512" + Crypto_HashAlgorithm_Sha2_256 -> "crypto.HashAlgorithm.Sha2_256" + Crypto_HashAlgorithm_Sha1 -> "crypto.HashAlgorithm.Sha1" + Crypto_HashAlgorithm_Blake2b_512 -> "crypto.HashAlgorithm.Blake2b_512" + Crypto_HashAlgorithm_Blake2b_256 -> "crypto.HashAlgorithm.Blake2b_256" + Crypto_HashAlgorithm_Blake2s_256 -> "crypto.HashAlgorithm.Blake2s_256" + Crypto_HashAlgorithm_Md5 -> "crypto.HashAlgorithm.Md5" + Crypto_hashBytes -> "crypto.hashBytes" + Crypto_hmacBytes -> "crypto.hmacBytes" + Crypto_hash -> "crypto.hash" + Crypto_hmac -> "crypto.hmac" + Crypto_Ed25519_sign_impl -> "crypto.Ed25519.sign.impl" + Crypto_Ed25519_verify_impl -> "crypto.Ed25519.verify.impl" + Crypto_Rsa_sign_impl -> "crypto.Rsa.sign.impl" + Crypto_Rsa_verify_impl -> "crypto.Rsa.verify.impl" + Universal_murmurHash -> "Universal.murmurHash" + IO_randomBytes -> "IO.randomBytes" + Bytes_zlib_compress -> "Bytes.zlib.compress" + Bytes_gzip_compress -> "Bytes.gzip.compress" + Bytes_zlib_decompress -> "Bytes.zlib.decompress" + Bytes_gzip_decompress -> "Bytes.gzip.decompress" + Bytes_toBase16 -> "Bytes.toBase16" + Bytes_toBase32 -> "Bytes.toBase32" + Bytes_toBase64 -> "Bytes.toBase64" + Bytes_toBase64UrlUnpadded -> "Bytes.toBase64UrlUnpadded" + Bytes_fromBase16 -> "Bytes.fromBase16" + Bytes_fromBase32 -> "Bytes.fromBase32" + Bytes_fromBase64 -> "Bytes.fromBase64" + Bytes_fromBase64UrlUnpadded -> "Bytes.fromBase64UrlUnpadded" + Bytes_decodeNat64be -> "Bytes.decodeNat64be" + Bytes_decodeNat64le -> "Bytes.decodeNat64le" + Bytes_decodeNat32be -> "Bytes.decodeNat32be" + Bytes_decodeNat32le -> "Bytes.decodeNat32le" + Bytes_decodeNat16be -> "Bytes.decodeNat16be" + Bytes_decodeNat16le -> "Bytes.decodeNat16le" + Bytes_encodeNat64be -> "Bytes.encodeNat64be" + Bytes_encodeNat64le -> "Bytes.encodeNat64le" + Bytes_encodeNat32be -> "Bytes.encodeNat32be" + Bytes_encodeNat32le -> "Bytes.encodeNat32le" + Bytes_encodeNat16be -> "Bytes.encodeNat16be" + Bytes_encodeNat16le -> "Bytes.encodeNat16le" + MutableArray_copyTo_force -> "MutableArray.copyTo!" + MutableByteArray_copyTo_force -> "MutableByteArray.copyTo!" + ImmutableArray_copyTo_force -> "ImmutableArray.copyTo!" + ImmutableArray_size -> "ImmutableArray.size" + MutableArray_size -> "MutableArray.size" + ImmutableByteArray_size -> "ImmutableByteArray.size" + MutableByteArray_size -> "MutableByteArray.size" + ImmutableByteArray_copyTo_force -> "ImmutableByteArray.copyTo!" + MutableArray_read -> "MutableArray.read" + MutableByteArray_read8 -> "MutableByteArray.read8" + MutableByteArray_read16be -> "MutableByteArray.read16be" + MutableByteArray_read24be -> "MutableByteArray.read24be" + MutableByteArray_read32be -> "MutableByteArray.read32be" + MutableByteArray_read40be -> "MutableByteArray.read40be" + MutableByteArray_read64be -> "MutableByteArray.read64be" + MutableArray_write -> "MutableArray.write" + MutableByteArray_write8 -> "MutableByteArray.write8" + MutableByteArray_write16be -> "MutableByteArray.write16be" + MutableByteArray_write32be -> "MutableByteArray.write32be" + MutableByteArray_write64be -> "MutableByteArray.write64be" + ImmutableArray_read -> "ImmutableArray.read" + ImmutableByteArray_read8 -> "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> "MutableByteArray.freeze!" + MutableArray_freeze_force -> "MutableArray.freeze!" + MutableByteArray_freeze -> "MutableByteArray.freeze" + MutableArray_freeze -> "MutableArray.freeze" + MutableByteArray_length -> "MutableByteArray.length" + ImmutableByteArray_length -> "ImmutableByteArray.length" + IO_array -> "IO.array" + IO_arrayOf -> "IO.arrayOf" + IO_bytearray -> "IO.bytearray" + IO_bytearrayOf -> "IO.bytearrayOf" + Scope_array -> "Scope.array" + Scope_arrayOf -> "Scope.arrayOf" + Scope_bytearray -> "Scope.bytearray" + Scope_bytearrayOf -> "Scope.bytearrayOf" + Text_patterns_literal -> "Text.patterns.literal" + Text_patterns_digit -> "Text.patterns.digit" + Text_patterns_letter -> "Text.patterns.letter" + Text_patterns_space -> "Text.patterns.space" + Text_patterns_punctuation -> "Text.patterns.punctuation" + Text_patterns_anyChar -> "Text.patterns.anyChar" + Text_patterns_eof -> "Text.patterns.eof" + Text_patterns_charRange -> "Text.patterns.charRange" + Text_patterns_notCharRange -> "Text.patterns.notCharRange" + Text_patterns_charIn -> "Text.patterns.charIn" + Text_patterns_notCharIn -> "Text.patterns.notCharIn" + Pattern_many -> "Pattern.many" + Pattern_many_corrected -> "Pattern.many.corrected" + Pattern_capture -> "Pattern.capture" + Pattern_captureAs -> "Pattern.captureAs" + Pattern_join -> "Pattern.join" + Pattern_or -> "Pattern.or" + Pattern_replicate -> "Pattern.replicate" + Pattern_run -> "Pattern.run" + Pattern_isMatch -> "Pattern.isMatch" + Char_Class_any -> "Char.Class.any" + Char_Class_not -> "Char.Class.not" + Char_Class_and -> "Char.Class.and" + Char_Class_or -> "Char.Class.or" + Char_Class_range -> "Char.Class.range" + Char_Class_anyOf -> "Char.Class.anyOf" + Char_Class_alphanumeric -> "Char.Class.alphanumeric" + Char_Class_upper -> "Char.Class.upper" + Char_Class_lower -> "Char.Class.lower" + Char_Class_whitespace -> "Char.Class.whitespace" + Char_Class_control -> "Char.Class.control" + Char_Class_printable -> "Char.Class.printable" + Char_Class_mark -> "Char.Class.mark" + Char_Class_number -> "Char.Class.number" + Char_Class_punctuation -> "Char.Class.punctuation" + Char_Class_symbol -> "Char.Class.symbol" + Char_Class_separator -> "Char.Class.separator" + Char_Class_letter -> "Char.Class.letter" + Char_Class_is -> "Char.Class.is" + Text_patterns_char -> "Text.patterns.char" diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs index 23d2a2e49e..e924243759 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -135,6 +135,7 @@ import Unison.Runtime.Exception (die) import Unison.Runtime.Foreign hiding (Failure) import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function (ForeignConvention (..)) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Symbol @@ -152,7 +153,7 @@ import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat import UnliftIO qualified -foreignCall :: MForeignFunc -> Args -> Stack -> IO Stack +foreignCall :: ForeignFunc -> Args -> Stack -> IO Stack foreignCall = \case IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index bf353baf93..c4deb3086f 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -119,6 +119,7 @@ import Unison.Runtime.MCode emitComb, emptyRNs, resolveCombs, + sanitizeCombs, ) import Unison.Runtime.MCode.Serialize import Unison.Runtime.Machine @@ -1254,9 +1255,9 @@ tryM = hRE (PE _ e) = pure $ Just e hRE (BU _ _ _) = pure $ Just "impossible" -runStandalone :: StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) -runStandalone sc init = - restoreCache sc >>= executeMainComb init +runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) +runStandalone sandboxed sc init = + restoreCache sandboxed sc >>= executeMainComb init -- | A version of the Code Cache designed to be serialized to disk as -- standalone bytecode. @@ -1318,10 +1319,10 @@ tabulateErrors errs = : P.wrap "The following errors occured while decompiling:" : (listErrors errs) -restoreCache :: StoredCache -> IO CCache -restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do +restoreCache :: Bool -> StoredCache -> IO CCache +restoreCache sandboxed (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do cc <- - CCache False debugText + CCache sandboxed debugText <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO (crs <> builtinTermBackref) @@ -1335,6 +1336,7 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do <*> newTVarIO (sbs <> baseSandboxInfo) let (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & EC.mapToList & foldMap @@ -1368,6 +1370,7 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do combs :: EnumMap Word64 (RCombs Val) combs = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 977107613d..ee3a682858 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -35,10 +35,10 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, - MForeignFunc (..), emitCombs, emitComb, resolveCombs, + sanitizeCombs, absurdCombs, emptyRNs, argsToLists, @@ -60,6 +60,8 @@ import Data.Functor ((<&>)) import Data.Map.Strict qualified as M import Data.Primitive.PrimArray import Data.Primitive.PrimArray qualified as PA +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Void (Void, absurd) import Data.Word (Word16, Word64) @@ -93,6 +95,7 @@ import Unison.Runtime.ANF pattern TVar, ) import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) import Unison.Util.EnumContainers as EC import Unison.Util.Text (Text) import Unison.Var (Var) @@ -463,256 +466,6 @@ data BPrim2 | REFW -- Ref.write deriving (Show, Eq, Ord, Enum, Bounded) --- | Enum representing every foreign call. -data MForeignFunc - = IO_UDP_clientSocket_impl_v1 - | IO_UDP_UDPSocket_recv_impl_v1 - | IO_UDP_UDPSocket_send_impl_v1 - | IO_UDP_UDPSocket_close_impl_v1 - | IO_UDP_ListenSocket_close_impl_v1 - | IO_UDP_UDPSocket_toText_impl_v1 - | IO_UDP_serverSocket_impl_v1 - | IO_UDP_ListenSocket_toText_impl_v1 - | IO_UDP_ListenSocket_recvFrom_impl_v1 - | IO_UDP_ClientSockAddr_toText_v1 - | IO_UDP_ListenSocket_sendTo_impl_v1 - | IO_openFile_impl_v3 - | IO_closeFile_impl_v3 - | IO_isFileEOF_impl_v3 - | IO_isFileOpen_impl_v3 - | IO_getEcho_impl_v1 - | IO_ready_impl_v1 - | IO_getChar_impl_v1 - | IO_isSeekable_impl_v3 - | IO_seekHandle_impl_v3 - | IO_handlePosition_impl_v3 - | IO_getBuffering_impl_v3 - | IO_setBuffering_impl_v3 - | IO_setEcho_impl_v1 - | IO_getLine_impl_v1 - | IO_getBytes_impl_v3 - | IO_getSomeBytes_impl_v1 - | IO_putBytes_impl_v3 - | IO_systemTime_impl_v3 - | IO_systemTimeMicroseconds_v1 - | Clock_internals_monotonic_v1 - | Clock_internals_realtime_v1 - | Clock_internals_processCPUTime_v1 - | Clock_internals_threadCPUTime_v1 - | Clock_internals_sec_v1 - | Clock_internals_nsec_v1 - | Clock_internals_systemTimeZone_v1 - | IO_getTempDirectory_impl_v3 - | IO_createTempDirectory_impl_v3 - | IO_getCurrentDirectory_impl_v3 - | IO_setCurrentDirectory_impl_v3 - | IO_fileExists_impl_v3 - | IO_getEnv_impl_v1 - | IO_getArgs_impl_v1 - | IO_isDirectory_impl_v3 - | IO_createDirectory_impl_v3 - | IO_removeDirectory_impl_v3 - | IO_renameDirectory_impl_v3 - | IO_directoryContents_impl_v3 - | IO_removeFile_impl_v3 - | IO_renameFile_impl_v3 - | IO_getFileTimestamp_impl_v3 - | IO_getFileSize_impl_v3 - | IO_serverSocket_impl_v3 - | Socket_toText - | Handle_toText - | ThreadId_toText - | IO_socketPort_impl_v3 - | IO_listen_impl_v3 - | IO_clientSocket_impl_v3 - | IO_closeSocket_impl_v3 - | IO_socketAccept_impl_v3 - | IO_socketSend_impl_v3 - | IO_socketReceive_impl_v3 - | IO_kill_impl_v3 - | IO_delay_impl_v3 - | IO_stdHandle - | IO_process_call - | IO_process_start - | IO_process_kill - | IO_process_wait - | IO_process_exitCode - | MVar_new - | MVar_newEmpty_v2 - | MVar_take_impl_v3 - | MVar_tryTake - | MVar_put_impl_v3 - | MVar_tryPut_impl_v3 - | MVar_swap_impl_v3 - | MVar_isEmpty - | MVar_read_impl_v3 - | MVar_tryRead_impl_v3 - | Char_toText - | Text_repeat - | Text_reverse - | Text_toUppercase - | Text_toLowercase - | Text_toUtf8 - | Text_fromUtf8_impl_v3 - | Tls_ClientConfig_default - | Tls_ServerConfig_default - | Tls_ClientConfig_certificates_set - | Tls_ServerConfig_certificates_set - | TVar_new - | TVar_read - | TVar_write - | TVar_newIO - | TVar_readIO - | TVar_swap - | STM_retry - | Promise_new - | Promise_read - | Promise_tryRead - | Promise_write - | Tls_newClient_impl_v3 - | Tls_newServer_impl_v3 - | Tls_handshake_impl_v3 - | Tls_send_impl_v3 - | Tls_decodeCert_impl_v3 - | Tls_encodeCert - | Tls_decodePrivateKey - | Tls_encodePrivateKey - | Tls_receive_impl_v3 - | Tls_terminate_impl_v3 - | Code_validateLinks - | Code_dependencies - | Code_serialize - | Code_deserialize - | Code_display - | Value_dependencies - | Value_serialize - | Value_deserialize - | Crypto_HashAlgorithm_Sha3_512 - | Crypto_HashAlgorithm_Sha3_256 - | Crypto_HashAlgorithm_Sha2_512 - | Crypto_HashAlgorithm_Sha2_256 - | Crypto_HashAlgorithm_Sha1 - | Crypto_HashAlgorithm_Blake2b_512 - | Crypto_HashAlgorithm_Blake2b_256 - | Crypto_HashAlgorithm_Blake2s_256 - | Crypto_HashAlgorithm_Md5 - | Crypto_hashBytes - | Crypto_hmacBytes - | Crypto_hash - | Crypto_hmac - | Crypto_Ed25519_sign_impl - | Crypto_Ed25519_verify_impl - | Crypto_Rsa_sign_impl - | Crypto_Rsa_verify_impl - | Universal_murmurHash - | IO_randomBytes - | Bytes_zlib_compress - | Bytes_gzip_compress - | Bytes_zlib_decompress - | Bytes_gzip_decompress - | Bytes_toBase16 - | Bytes_toBase32 - | Bytes_toBase64 - | Bytes_toBase64UrlUnpadded - | Bytes_fromBase16 - | Bytes_fromBase32 - | Bytes_fromBase64 - | Bytes_fromBase64UrlUnpadded - | Bytes_decodeNat64be - | Bytes_decodeNat64le - | Bytes_decodeNat32be - | Bytes_decodeNat32le - | Bytes_decodeNat16be - | Bytes_decodeNat16le - | Bytes_encodeNat64be - | Bytes_encodeNat64le - | Bytes_encodeNat32be - | Bytes_encodeNat32le - | Bytes_encodeNat16be - | Bytes_encodeNat16le - | MutableArray_copyTo_force - | MutableByteArray_copyTo_force - | ImmutableArray_copyTo_force - | ImmutableArray_size - | MutableArray_size - | ImmutableByteArray_size - | MutableByteArray_size - | ImmutableByteArray_copyTo_force - | MutableArray_read - | MutableByteArray_read8 - | MutableByteArray_read16be - | MutableByteArray_read24be - | MutableByteArray_read32be - | MutableByteArray_read40be - | MutableByteArray_read64be - | MutableArray_write - | MutableByteArray_write8 - | MutableByteArray_write16be - | MutableByteArray_write32be - | MutableByteArray_write64be - | ImmutableArray_read - | ImmutableByteArray_read8 - | ImmutableByteArray_read16be - | ImmutableByteArray_read24be - | ImmutableByteArray_read32be - | ImmutableByteArray_read40be - | ImmutableByteArray_read64be - | MutableByteArray_freeze_force - | MutableArray_freeze_force - | MutableByteArray_freeze - | MutableArray_freeze - | MutableByteArray_length - | ImmutableByteArray_length - | IO_array - | IO_arrayOf - | IO_bytearray - | IO_bytearrayOf - | Scope_array - | Scope_arrayOf - | Scope_bytearray - | Scope_bytearrayOf - | Text_patterns_literal - | Text_patterns_digit - | Text_patterns_letter - | Text_patterns_space - | Text_patterns_punctuation - | Text_patterns_anyChar - | Text_patterns_eof - | Text_patterns_charRange - | Text_patterns_notCharRange - | Text_patterns_charIn - | Text_patterns_notCharIn - | Pattern_many - | Pattern_many_corrected - | Pattern_capture - | Pattern_captureAs - | Pattern_join - | Pattern_or - | Pattern_replicate - | Pattern_run - | Pattern_isMatch - | Char_Class_any - | Char_Class_not - | Char_Class_and - | Char_Class_or - | Char_Class_range - | Char_Class_anyOf - | Char_Class_alphanumeric - | Char_Class_upper - | Char_Class_lower - | Char_Class_whitespace - | Char_Class_control - | Char_Class_printable - | Char_Class_mark - | Char_Class_number - | Char_Class_punctuation - | Char_Class_symbol - | Char_Class_separator - | Char_Class_letter - | Char_Class_is - | Text_patterns_char - deriving (Show, Eq, Ord, Enum, Bounded) - data MLit = MI !Int | MN !Word64 @@ -754,7 +507,7 @@ data GInstr comb | -- Call out to a Haskell function. ForeignCall !Bool -- catch exceptions - !MForeignFunc -- FFI call + !ForeignFunc -- FFI call !Args -- arguments | -- Set the value of a dynamic reference SetDyn @@ -1648,257 +1401,8 @@ emitPOp ANF.TFRC = \case -- to 'foreing function' calls, but there is a special case for the -- standard handle access function, because it does not yield an -- explicit error. -emitFOp :: ANF.ForeignFunc -> Args -> Instr -emitFOp fop = ForeignCall True (convertFF fop) - where - convertFF :: ANF.ForeignFunc -> MForeignFunc - convertFF = \case - ANF.IO_UDP_clientSocket_impl_v1 -> IO_UDP_clientSocket_impl_v1 - ANF.IO_UDP_UDPSocket_recv_impl_v1 -> IO_UDP_UDPSocket_recv_impl_v1 - ANF.IO_UDP_UDPSocket_send_impl_v1 -> IO_UDP_UDPSocket_send_impl_v1 - ANF.IO_UDP_UDPSocket_close_impl_v1 -> IO_UDP_UDPSocket_close_impl_v1 - ANF.IO_UDP_ListenSocket_close_impl_v1 -> IO_UDP_ListenSocket_close_impl_v1 - ANF.IO_UDP_UDPSocket_toText_impl_v1 -> IO_UDP_UDPSocket_toText_impl_v1 - ANF.IO_UDP_serverSocket_impl_v1 -> IO_UDP_serverSocket_impl_v1 - ANF.IO_UDP_ListenSocket_toText_impl_v1 -> IO_UDP_ListenSocket_toText_impl_v1 - ANF.IO_UDP_ListenSocket_recvFrom_impl_v1 -> IO_UDP_ListenSocket_recvFrom_impl_v1 - ANF.IO_UDP_ClientSockAddr_toText_v1 -> IO_UDP_ClientSockAddr_toText_v1 - ANF.IO_UDP_ListenSocket_sendTo_impl_v1 -> IO_UDP_ListenSocket_sendTo_impl_v1 - ANF.IO_openFile_impl_v3 -> IO_openFile_impl_v3 - ANF.IO_closeFile_impl_v3 -> IO_closeFile_impl_v3 - ANF.IO_isFileEOF_impl_v3 -> IO_isFileEOF_impl_v3 - ANF.IO_isFileOpen_impl_v3 -> IO_isFileOpen_impl_v3 - ANF.IO_getEcho_impl_v1 -> IO_getEcho_impl_v1 - ANF.IO_ready_impl_v1 -> IO_ready_impl_v1 - ANF.IO_getChar_impl_v1 -> IO_getChar_impl_v1 - ANF.IO_isSeekable_impl_v3 -> IO_isSeekable_impl_v3 - ANF.IO_seekHandle_impl_v3 -> IO_seekHandle_impl_v3 - ANF.IO_handlePosition_impl_v3 -> IO_handlePosition_impl_v3 - ANF.IO_getBuffering_impl_v3 -> IO_getBuffering_impl_v3 - ANF.IO_setBuffering_impl_v3 -> IO_setBuffering_impl_v3 - ANF.IO_setEcho_impl_v1 -> IO_setEcho_impl_v1 - ANF.IO_getLine_impl_v1 -> IO_getLine_impl_v1 - ANF.IO_getBytes_impl_v3 -> IO_getBytes_impl_v3 - ANF.IO_getSomeBytes_impl_v1 -> IO_getSomeBytes_impl_v1 - ANF.IO_putBytes_impl_v3 -> IO_putBytes_impl_v3 - ANF.IO_systemTime_impl_v3 -> IO_systemTime_impl_v3 - ANF.IO_systemTimeMicroseconds_v1 -> IO_systemTimeMicroseconds_v1 - ANF.Clock_internals_monotonic_v1 -> Clock_internals_monotonic_v1 - ANF.Clock_internals_realtime_v1 -> Clock_internals_realtime_v1 - ANF.Clock_internals_processCPUTime_v1 -> Clock_internals_processCPUTime_v1 - ANF.Clock_internals_threadCPUTime_v1 -> Clock_internals_threadCPUTime_v1 - ANF.Clock_internals_sec_v1 -> Clock_internals_sec_v1 - ANF.Clock_internals_nsec_v1 -> Clock_internals_nsec_v1 - ANF.Clock_internals_systemTimeZone_v1 -> Clock_internals_systemTimeZone_v1 - ANF.IO_getTempDirectory_impl_v3 -> IO_getTempDirectory_impl_v3 - ANF.IO_createTempDirectory_impl_v3 -> IO_createTempDirectory_impl_v3 - ANF.IO_getCurrentDirectory_impl_v3 -> IO_getCurrentDirectory_impl_v3 - ANF.IO_setCurrentDirectory_impl_v3 -> IO_setCurrentDirectory_impl_v3 - ANF.IO_fileExists_impl_v3 -> IO_fileExists_impl_v3 - ANF.IO_getEnv_impl_v1 -> IO_getEnv_impl_v1 - ANF.IO_getArgs_impl_v1 -> IO_getArgs_impl_v1 - ANF.IO_isDirectory_impl_v3 -> IO_isDirectory_impl_v3 - ANF.IO_createDirectory_impl_v3 -> IO_createDirectory_impl_v3 - ANF.IO_removeDirectory_impl_v3 -> IO_removeDirectory_impl_v3 - ANF.IO_renameDirectory_impl_v3 -> IO_renameDirectory_impl_v3 - ANF.IO_directoryContents_impl_v3 -> IO_directoryContents_impl_v3 - ANF.IO_removeFile_impl_v3 -> IO_removeFile_impl_v3 - ANF.IO_renameFile_impl_v3 -> IO_renameFile_impl_v3 - ANF.IO_getFileTimestamp_impl_v3 -> IO_getFileTimestamp_impl_v3 - ANF.IO_getFileSize_impl_v3 -> IO_getFileSize_impl_v3 - ANF.IO_serverSocket_impl_v3 -> IO_serverSocket_impl_v3 - ANF.Socket_toText -> Socket_toText - ANF.Handle_toText -> Handle_toText - ANF.ThreadId_toText -> ThreadId_toText - ANF.IO_socketPort_impl_v3 -> IO_socketPort_impl_v3 - ANF.IO_listen_impl_v3 -> IO_listen_impl_v3 - ANF.IO_clientSocket_impl_v3 -> IO_clientSocket_impl_v3 - ANF.IO_closeSocket_impl_v3 -> IO_closeSocket_impl_v3 - ANF.IO_socketAccept_impl_v3 -> IO_socketAccept_impl_v3 - ANF.IO_socketSend_impl_v3 -> IO_socketSend_impl_v3 - ANF.IO_socketReceive_impl_v3 -> IO_socketReceive_impl_v3 - ANF.IO_kill_impl_v3 -> IO_kill_impl_v3 - ANF.IO_delay_impl_v3 -> IO_delay_impl_v3 - ANF.IO_stdHandle -> IO_stdHandle - ANF.IO_process_call -> IO_process_call - ANF.IO_process_start -> IO_process_start - ANF.IO_process_kill -> IO_process_kill - ANF.IO_process_wait -> IO_process_wait - ANF.IO_process_exitCode -> IO_process_exitCode - ANF.MVar_new -> MVar_new - ANF.MVar_newEmpty_v2 -> MVar_newEmpty_v2 - ANF.MVar_take_impl_v3 -> MVar_take_impl_v3 - ANF.MVar_tryTake -> MVar_tryTake - ANF.MVar_put_impl_v3 -> MVar_put_impl_v3 - ANF.MVar_tryPut_impl_v3 -> MVar_tryPut_impl_v3 - ANF.MVar_swap_impl_v3 -> MVar_swap_impl_v3 - ANF.MVar_isEmpty -> MVar_isEmpty - ANF.MVar_read_impl_v3 -> MVar_read_impl_v3 - ANF.MVar_tryRead_impl_v3 -> MVar_tryRead_impl_v3 - ANF.Char_toText -> Char_toText - ANF.Text_repeat -> Text_repeat - ANF.Text_reverse -> Text_reverse - ANF.Text_toUppercase -> Text_toUppercase - ANF.Text_toLowercase -> Text_toLowercase - ANF.Text_toUtf8 -> Text_toUtf8 - ANF.Text_fromUtf8_impl_v3 -> Text_fromUtf8_impl_v3 - ANF.Tls_ClientConfig_default -> Tls_ClientConfig_default - ANF.Tls_ServerConfig_default -> Tls_ServerConfig_default - ANF.Tls_ClientConfig_certificates_set -> Tls_ClientConfig_certificates_set - ANF.Tls_ServerConfig_certificates_set -> Tls_ServerConfig_certificates_set - ANF.TVar_new -> TVar_new - ANF.TVar_read -> TVar_read - ANF.TVar_write -> TVar_write - ANF.TVar_newIO -> TVar_newIO - ANF.TVar_readIO -> TVar_readIO - ANF.TVar_swap -> TVar_swap - ANF.STM_retry -> STM_retry - ANF.Promise_new -> Promise_new - ANF.Promise_read -> Promise_read - ANF.Promise_tryRead -> Promise_tryRead - ANF.Promise_write -> Promise_write - ANF.Tls_newClient_impl_v3 -> Tls_newClient_impl_v3 - ANF.Tls_newServer_impl_v3 -> Tls_newServer_impl_v3 - ANF.Tls_handshake_impl_v3 -> Tls_handshake_impl_v3 - ANF.Tls_send_impl_v3 -> Tls_send_impl_v3 - ANF.Tls_decodeCert_impl_v3 -> Tls_decodeCert_impl_v3 - ANF.Tls_encodeCert -> Tls_encodeCert - ANF.Tls_decodePrivateKey -> Tls_decodePrivateKey - ANF.Tls_encodePrivateKey -> Tls_encodePrivateKey - ANF.Tls_receive_impl_v3 -> Tls_receive_impl_v3 - ANF.Tls_terminate_impl_v3 -> Tls_terminate_impl_v3 - ANF.Code_validateLinks -> Code_validateLinks - ANF.Code_dependencies -> Code_dependencies - ANF.Code_serialize -> Code_serialize - ANF.Code_deserialize -> Code_deserialize - ANF.Code_display -> Code_display - ANF.Value_dependencies -> Value_dependencies - ANF.Value_serialize -> Value_serialize - ANF.Value_deserialize -> Value_deserialize - ANF.Crypto_HashAlgorithm_Sha3_512 -> Crypto_HashAlgorithm_Sha3_512 - ANF.Crypto_HashAlgorithm_Sha3_256 -> Crypto_HashAlgorithm_Sha3_256 - ANF.Crypto_HashAlgorithm_Sha2_512 -> Crypto_HashAlgorithm_Sha2_512 - ANF.Crypto_HashAlgorithm_Sha2_256 -> Crypto_HashAlgorithm_Sha2_256 - ANF.Crypto_HashAlgorithm_Sha1 -> Crypto_HashAlgorithm_Sha1 - ANF.Crypto_HashAlgorithm_Blake2b_512 -> Crypto_HashAlgorithm_Blake2b_512 - ANF.Crypto_HashAlgorithm_Blake2b_256 -> Crypto_HashAlgorithm_Blake2b_256 - ANF.Crypto_HashAlgorithm_Blake2s_256 -> Crypto_HashAlgorithm_Blake2s_256 - ANF.Crypto_HashAlgorithm_Md5 -> Crypto_HashAlgorithm_Md5 - ANF.Crypto_hashBytes -> Crypto_hashBytes - ANF.Crypto_hmacBytes -> Crypto_hmacBytes - ANF.Crypto_hash -> Crypto_hash - ANF.Crypto_hmac -> Crypto_hmac - ANF.Crypto_Ed25519_sign_impl -> Crypto_Ed25519_sign_impl - ANF.Crypto_Ed25519_verify_impl -> Crypto_Ed25519_verify_impl - ANF.Crypto_Rsa_sign_impl -> Crypto_Rsa_sign_impl - ANF.Crypto_Rsa_verify_impl -> Crypto_Rsa_verify_impl - ANF.Universal_murmurHash -> Universal_murmurHash - ANF.IO_randomBytes -> IO_randomBytes - ANF.Bytes_zlib_compress -> Bytes_zlib_compress - ANF.Bytes_gzip_compress -> Bytes_gzip_compress - ANF.Bytes_zlib_decompress -> Bytes_zlib_decompress - ANF.Bytes_gzip_decompress -> Bytes_gzip_decompress - ANF.Bytes_toBase16 -> Bytes_toBase16 - ANF.Bytes_toBase32 -> Bytes_toBase32 - ANF.Bytes_toBase64 -> Bytes_toBase64 - ANF.Bytes_toBase64UrlUnpadded -> Bytes_toBase64UrlUnpadded - ANF.Bytes_fromBase16 -> Bytes_fromBase16 - ANF.Bytes_fromBase32 -> Bytes_fromBase32 - ANF.Bytes_fromBase64 -> Bytes_fromBase64 - ANF.Bytes_fromBase64UrlUnpadded -> Bytes_fromBase64UrlUnpadded - ANF.Bytes_decodeNat64be -> Bytes_decodeNat64be - ANF.Bytes_decodeNat64le -> Bytes_decodeNat64le - ANF.Bytes_decodeNat32be -> Bytes_decodeNat32be - ANF.Bytes_decodeNat32le -> Bytes_decodeNat32le - ANF.Bytes_decodeNat16be -> Bytes_decodeNat16be - ANF.Bytes_decodeNat16le -> Bytes_decodeNat16le - ANF.Bytes_encodeNat64be -> Bytes_encodeNat64be - ANF.Bytes_encodeNat64le -> Bytes_encodeNat64le - ANF.Bytes_encodeNat32be -> Bytes_encodeNat32be - ANF.Bytes_encodeNat32le -> Bytes_encodeNat32le - ANF.Bytes_encodeNat16be -> Bytes_encodeNat16be - ANF.Bytes_encodeNat16le -> Bytes_encodeNat16le - ANF.MutableArray_copyTo_force -> MutableArray_copyTo_force - ANF.MutableByteArray_copyTo_force -> MutableByteArray_copyTo_force - ANF.ImmutableArray_copyTo_force -> ImmutableArray_copyTo_force - ANF.ImmutableArray_size -> ImmutableArray_size - ANF.MutableArray_size -> MutableArray_size - ANF.ImmutableByteArray_size -> ImmutableByteArray_size - ANF.MutableByteArray_size -> MutableByteArray_size - ANF.ImmutableByteArray_copyTo_force -> ImmutableByteArray_copyTo_force - ANF.MutableArray_read -> MutableArray_read - ANF.MutableByteArray_read8 -> MutableByteArray_read8 - ANF.MutableByteArray_read16be -> MutableByteArray_read16be - ANF.MutableByteArray_read24be -> MutableByteArray_read24be - ANF.MutableByteArray_read32be -> MutableByteArray_read32be - ANF.MutableByteArray_read40be -> MutableByteArray_read40be - ANF.MutableByteArray_read64be -> MutableByteArray_read64be - ANF.MutableArray_write -> MutableArray_write - ANF.MutableByteArray_write8 -> MutableByteArray_write8 - ANF.MutableByteArray_write16be -> MutableByteArray_write16be - ANF.MutableByteArray_write32be -> MutableByteArray_write32be - ANF.MutableByteArray_write64be -> MutableByteArray_write64be - ANF.ImmutableArray_read -> ImmutableArray_read - ANF.ImmutableByteArray_read8 -> ImmutableByteArray_read8 - ANF.ImmutableByteArray_read16be -> ImmutableByteArray_read16be - ANF.ImmutableByteArray_read24be -> ImmutableByteArray_read24be - ANF.ImmutableByteArray_read32be -> ImmutableByteArray_read32be - ANF.ImmutableByteArray_read40be -> ImmutableByteArray_read40be - ANF.ImmutableByteArray_read64be -> ImmutableByteArray_read64be - ANF.MutableByteArray_freeze_force -> MutableByteArray_freeze_force - ANF.MutableArray_freeze_force -> MutableArray_freeze_force - ANF.MutableByteArray_freeze -> MutableByteArray_freeze - ANF.MutableArray_freeze -> MutableArray_freeze - ANF.MutableByteArray_length -> MutableByteArray_length - ANF.ImmutableByteArray_length -> ImmutableByteArray_length - ANF.IO_array -> IO_array - ANF.IO_arrayOf -> IO_arrayOf - ANF.IO_bytearray -> IO_bytearray - ANF.IO_bytearrayOf -> IO_bytearrayOf - ANF.Scope_array -> Scope_array - ANF.Scope_arrayOf -> Scope_arrayOf - ANF.Scope_bytearray -> Scope_bytearray - ANF.Scope_bytearrayOf -> Scope_bytearrayOf - ANF.Text_patterns_literal -> Text_patterns_literal - ANF.Text_patterns_digit -> Text_patterns_digit - ANF.Text_patterns_letter -> Text_patterns_letter - ANF.Text_patterns_space -> Text_patterns_space - ANF.Text_patterns_punctuation -> Text_patterns_punctuation - ANF.Text_patterns_anyChar -> Text_patterns_anyChar - ANF.Text_patterns_eof -> Text_patterns_eof - ANF.Text_patterns_charRange -> Text_patterns_charRange - ANF.Text_patterns_notCharRange -> Text_patterns_notCharRange - ANF.Text_patterns_charIn -> Text_patterns_charIn - ANF.Text_patterns_notCharIn -> Text_patterns_notCharIn - ANF.Pattern_many -> Pattern_many - ANF.Pattern_many_corrected -> Pattern_many_corrected - ANF.Pattern_capture -> Pattern_capture - ANF.Pattern_captureAs -> Pattern_captureAs - ANF.Pattern_join -> Pattern_join - ANF.Pattern_or -> Pattern_or - ANF.Pattern_replicate -> Pattern_replicate - ANF.Pattern_run -> Pattern_run - ANF.Pattern_isMatch -> Pattern_isMatch - ANF.Char_Class_any -> Char_Class_any - ANF.Char_Class_not -> Char_Class_not - ANF.Char_Class_and -> Char_Class_and - ANF.Char_Class_or -> Char_Class_or - ANF.Char_Class_range -> Char_Class_range - ANF.Char_Class_anyOf -> Char_Class_anyOf - ANF.Char_Class_alphanumeric -> Char_Class_alphanumeric - ANF.Char_Class_upper -> Char_Class_upper - ANF.Char_Class_lower -> Char_Class_lower - ANF.Char_Class_whitespace -> Char_Class_whitespace - ANF.Char_Class_control -> Char_Class_control - ANF.Char_Class_printable -> Char_Class_printable - ANF.Char_Class_mark -> Char_Class_mark - ANF.Char_Class_number -> Char_Class_number - ANF.Char_Class_punctuation -> Char_Class_punctuation - ANF.Char_Class_symbol -> Char_Class_symbol - ANF.Char_Class_separator -> Char_Class_separator - ANF.Char_Class_letter -> Char_Class_letter - ANF.Char_Class_is -> Char_Class_is - ANF.Text_patterns_char -> Text_patterns_char +emitFOp :: ForeignFunc -> Args -> Instr +emitFOp fop = ForeignCall True fop -- Helper functions for packing the variable argument representation -- into the indexes stored in prim op instructions @@ -2301,3 +1805,38 @@ prettyIns i = shows i prettyArgs :: Args -> ShowS prettyArgs ZArgs = showString "ZArgs" prettyArgs v = showParen True $ shows v + +sanitizeCombs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) +sanitizeCombs sanitize sandboxedForeigns m + | sanitize = (fmap . fmap) (sanitizeComb sandboxedForeigns) m + | otherwise = m + +sanitizeComb :: Set ForeignFunc -> GComb Void CombIx -> GComb Void CombIx +sanitizeComb sandboxedForeigns = \case + Lam a b s -> Lam a b (sanitizeSection sandboxedForeigns s) + +-- | Crawl the source code and statically replace all sandboxed foreign funcs with an error. +sanitizeSection :: Set ForeignFunc -> GSection CombIx -> GSection CombIx +sanitizeSection sandboxedForeigns section = case section of + Ins (ForeignCall _ f as) nx + | Set.member f sandboxedForeigns -> Ins (SandboxingFailure (foreignFuncBuiltinName f)) (sanitizeSection sandboxedForeigns nx) + | otherwise -> Ins (ForeignCall True f as) (sanitizeSection sandboxedForeigns nx) + Ins i nx -> Ins i (sanitizeSection sandboxedForeigns nx) + App {} -> section + Call {} -> section + Jump {} -> section + Match i bs -> Match i (sanitizeBranches sandboxedForeigns bs) + Yield {} -> section + Let s i f b -> Let (sanitizeSection sandboxedForeigns s) i f (sanitizeSection sandboxedForeigns b) + Die {} -> section + Exit -> section + DMatch i j bs -> DMatch i j (sanitizeBranches sandboxedForeigns bs) + NMatch i j bs -> NMatch i j (sanitizeBranches sandboxedForeigns bs) + RMatch i s bs -> RMatch i (sanitizeSection sandboxedForeigns s) (fmap (sanitizeBranches sandboxedForeigns) bs) + +sanitizeBranches :: Set ForeignFunc -> GBranch CombIx -> GBranch CombIx +sanitizeBranches sandboxedForeigns = \case + Test1 i s d -> Test1 i (sanitizeSection sandboxedForeigns s) (sanitizeSection sandboxedForeigns d) + Test2 i s j t d -> Test2 i (sanitizeSection sandboxedForeigns s) j (sanitizeSection sandboxedForeigns t) (sanitizeSection sandboxedForeigns d) + TestW d m -> TestW (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) + TestT d m -> TestT (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 2b0fd4aa81..e6946403d9 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -19,6 +19,7 @@ import Data.Word (Word64) import GHC.Exts (IsList (..)) import Unison.Runtime.ANF (PackedTag (..)) import Unison.Runtime.Array (PrimArray) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.MCode hiding (MatchT) import Unison.Runtime.Serialize import Unison.Util.Text qualified as Util.Text @@ -54,11 +55,11 @@ getComb = Lam <$> gInt <*> gInt <*> getSection CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" -getMForeignFunc :: (MonadGet m) => m MForeignFunc +getMForeignFunc :: (MonadGet m) => m ForeignFunc getMForeignFunc = do toEnum <$> gInt -putMForeignFunc :: (MonadPut m) => MForeignFunc -> m () +putMForeignFunc :: (MonadPut m) => ForeignFunc -> m () putMForeignFunc = pInt . fromEnum data SectionT diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 94a075b6b5..95b951514f 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -177,6 +177,7 @@ baseCCache sandboxed = do combs :: EnumMap Word64 MCombs combs = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing @@ -493,8 +494,8 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) stk <- bump stk pokeS stk . encodeSandboxListResult =<< sandboxList env tl pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim1 op i) = do - stk <- bprim1 stk op i +exec !env !denv !_activeThreads !stk !k _ (BPrim1 op i) = do + stk <- bprim1 env stk op i pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do s <- peekOffS stk i @@ -565,17 +566,19 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) exec !_ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do stk <- bprim2 stk op i j pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) = do - (ref :: IORef Val) <- peekOffBi stk refI - -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it - -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal - -- forcing of the values and tickets. - !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI - v <- peekOff stk valI - (r, _) <- Atomic.casIORef ref ticket v - stk <- bump stk - pokeBool stk r - pure (denv, stk, k) +exec !env !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) + | sandboxed env = die "attempted to use sandboxed operation: Ref.cas" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk refI + -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it + -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal + -- forcing of the values and tickets. + !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI + v <- peekOff stk valI + (r, _) <- Atomic.casIORef ref ticket v + stk <- bump stk + pokeBool stk r + pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (Pack r t args) = do clo <- buildData stk r t args stk <- bump stk @@ -1533,36 +1536,37 @@ uprim2 !stk IORB !i !j = do {-# INLINE uprim2 #-} bprim1 :: + CCache -> Stack -> BPrim1 -> Int -> IO Stack -bprim1 !stk SIZT i = do +bprim1 !_env !stk SIZT i = do t <- peekOffBi stk i stk <- bump stk unsafePokeIasN stk $ Util.Text.size t pure stk -bprim1 !stk SIZS i = do +bprim1 !_env !stk SIZS i = do s <- peekOffS stk i stk <- bump stk unsafePokeIasN stk $ Sq.length s pure stk -bprim1 !stk ITOT i = do +bprim1 !_env !stk ITOT i = do n <- upeekOff stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show n pure stk -bprim1 !stk NTOT i = do +bprim1 !_env !stk NTOT i = do n <- peekOffN stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show n pure stk -bprim1 !stk FTOT i = do +bprim1 !_env !stk FTOT i = do f <- peekOffD stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show f pure stk -bprim1 !stk USNC i = +bprim1 !_env !stk USNC i = peekOffBi stk i >>= \t -> case Util.Text.unsnoc t of Nothing -> do stk <- bump stk @@ -1574,7 +1578,7 @@ bprim1 !stk USNC i = pokeOffBi stk 1 t -- remaining text pokeTag stk 1 -- 'Just' tag pure stk -bprim1 !stk UCNS i = +bprim1 !_env !stk UCNS i = peekOffBi stk i >>= \t -> case Util.Text.uncons t of Nothing -> do stk <- bump stk @@ -1586,7 +1590,7 @@ bprim1 !stk UCNS i = pokeOffC stk 1 $ c -- char value pokeTag stk 1 -- 'Just' tag pure stk -bprim1 !stk TTOI i = +bprim1 !_env !stk TTOI i = peekOffBi stk i >>= \t -> case readm $ Util.Text.unpack t of Just n | fromIntegral (minBound :: Int) <= n, @@ -1602,7 +1606,7 @@ bprim1 !stk TTOI i = where readm ('+' : s) = readMaybe s readm s = readMaybe s -bprim1 !stk TTON i = +bprim1 !_env !stk TTON i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Just n | 0 <= n, @@ -1615,7 +1619,7 @@ bprim1 !stk TTON i = stk <- bump stk pokeTag stk 0 pure stk -bprim1 !stk TTOF i = +bprim1 !_env !stk TTOF i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Nothing -> do stk <- bump stk @@ -1626,7 +1630,7 @@ bprim1 !stk TTOF i = pokeTag stk 1 pokeOffD stk 1 f pure stk -bprim1 !stk VWLS i = +bprim1 !_env !stk VWLS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk @@ -1638,7 +1642,7 @@ bprim1 !stk VWLS i = pokeOff stk 1 x -- head pokeTag stk 1 -- ':<|' tag pure stk -bprim1 !stk VWRS i = +bprim1 !_env !stk VWRS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk @@ -1650,7 +1654,7 @@ bprim1 !stk VWRS i = pokeOffS stk 1 xs -- remaining seq pokeTag stk 1 -- ':|>' tag pure stk -bprim1 !stk PAKT i = do +bprim1 !_env !stk PAKT i = do s <- peekOffS stk i stk <- bump stk pokeBi stk . Util.Text.pack . toList $ val2char <$> s @@ -1659,7 +1663,7 @@ bprim1 !stk PAKT i = do val2char :: Val -> Char val2char (CharVal c) = c val2char c = error $ "pack text: non-character closure: " ++ show c -bprim1 !stk UPKT i = do +bprim1 !_env !stk UPKT i = do t <- peekOffBi stk i stk <- bump stk pokeS stk @@ -1668,7 +1672,7 @@ bprim1 !stk UPKT i = do . Util.Text.unpack $ t pure stk -bprim1 !stk PAKB i = do +bprim1 !_env !stk PAKB i = do s <- peekOffS stk i stk <- bump stk pokeBi stk . By.fromWord8s . fmap val2w8 $ toList s @@ -1678,18 +1682,18 @@ bprim1 !stk PAKB i = do val2w8 :: Val -> Word8 val2w8 (NatVal n) = toEnum . fromEnum $ n val2w8 c = error $ "pack bytes: non-natural closure: " ++ show c -bprim1 !stk UPKB i = do +bprim1 !_env !stk UPKB i = do b <- peekOffBi stk i stk <- bump stk pokeS stk . Sq.fromList . fmap (NatVal . toEnum @Word64 . fromEnum @Word8) $ By.toWord8s b pure stk -bprim1 !stk SIZB i = do +bprim1 !_env !stk SIZB i = do b <- peekOffBi stk i stk <- bump stk unsafePokeIasN stk $ By.size b pure stk -bprim1 !stk FLTB i = do +bprim1 !_env !stk FLTB i = do b <- peekOffBi stk i stk <- bump stk pokeBi stk $ By.flatten b @@ -1702,13 +1706,13 @@ bprim1 !stk FLTB i = do -- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2 -- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286 -- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298 -bprim1 !stk REFR i = do +bprim1 !_env !stk REFR i = do (ref :: IORef Val) <- peekOffBi stk i v <- IORef.readIORef ref stk <- bump stk poke stk v pure stk -bprim1 !stk REFN i = do +bprim1 !_env !stk REFN i = do -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal -- forcing of the values and tickets. @@ -1717,13 +1721,15 @@ bprim1 !stk REFN i = do stk <- bump stk pokeBi stk ref pure stk -bprim1 !stk RRFC i = do - (ref :: IORef Val) <- peekOffBi stk i - ticket <- Atomic.readForCAS ref - stk <- bump stk - pokeBi stk ticket - pure stk -bprim1 !stk TIKR i = do +bprim1 !env !stk RRFC i + | sandboxed env = die "attempted to use sandboxed operation: Ref.readForCAS" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk i + ticket <- Atomic.readForCAS ref + stk <- bump stk + pokeBi stk ticket + pure stk +bprim1 !_env !stk TIKR i = do (t :: Atomic.Ticket Val) <- peekOffBi stk i stk <- bump stk let v = Atomic.peekTicket t @@ -1731,15 +1737,15 @@ bprim1 !stk TIKR i = do pure stk -- impossible -bprim1 !stk MISS _ = pure stk -bprim1 !stk CACH _ = pure stk -bprim1 !stk LKUP _ = pure stk -bprim1 !stk CVLD _ = pure stk -bprim1 !stk TLTT _ = pure stk -bprim1 !stk LOAD _ = pure stk -bprim1 !stk VALU _ = pure stk -bprim1 !stk DBTX _ = pure stk -bprim1 !stk SDBL _ = pure stk +bprim1 !_env !stk MISS _ = pure stk +bprim1 !_env !stk CACH _ = pure stk +bprim1 !_env !stk LKUP _ = pure stk +bprim1 !_env !stk CVLD _ = pure stk +bprim1 !_env !stk TLTT _ = pure stk +bprim1 !_env !stk LOAD _ = pure stk +bprim1 !_env !stk VALU _ = pure stk +bprim1 !_env !stk DBTX _ = pure stk +bprim1 !_env !stk SDBL _ = pure stk {-# INLINE bprim1 #-} bprim2 :: @@ -2261,7 +2267,8 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do newCombRefs <- updateMap combRefUpdates (combRefs cc) (unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) - unresolvedNewCombs = absurdCombs . mapFromList $ zipWith combinate [ntm ..] rgs + unresolvedNewCombs = + absurdCombs . sanitizeCombs (sandboxed cc) sandboxedForeignFuncs . mapFromList $ zipWith combinate [ntm ..] rgs (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = EC.mapToList unresolvedNewCombs & foldMap \(w, gcombs) -> if EC.member w newCacheableCombs diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index 7b1eb787b3..10fac3e1a2 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -44,6 +44,7 @@ library Unison.Runtime.Exception Unison.Runtime.Foreign Unison.Runtime.Foreign.Function + Unison.Runtime.Foreign.Function.Type Unison.Runtime.Foreign.Impl Unison.Runtime.Interface Unison.Runtime.IOSource