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 259987f07c..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 (..), - FOp, 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) @@ -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 diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 9b6c575232..4b0759ad0f 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -25,8 +25,8 @@ 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.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 +317,7 @@ putGroup :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map 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) => Map 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 -> + Map ForeignFunc Text -> [v] -> SuperNormal v -> m () @@ -384,7 +384,7 @@ putNormal :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> ANormal v -> m () @@ -482,7 +482,7 @@ putFunc :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> Func v -> m () @@ -496,7 +496,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 +757,7 @@ putBranches :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> Branched (ANormal v) -> m () @@ -825,7 +825,7 @@ putCase :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map 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 :: Map 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 -> + 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 6c292f4a78..f6e610cdf7 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -8,186 +8,42 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Unison.Runtime.Builtin - ( builtinLookup, - builtinTermNumbering, + ( builtinTermNumbering, builtinTypeNumbering, builtinTermBackref, builtinTypeBackref, - builtinForeigns, builtinArities, builtinInlineInfo, - sandboxedForeigns, numberedTermLookup, Sandbox (..), baseSandboxInfo, + unitValue, + natValue, + builtinForeignNames, + sandboxedForeignFuncs, ) 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.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) +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 @@ -887,7 +743,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 = @@ -1116,30 +972,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] @@ -1166,7 +1022,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] @@ -1834,8 +1690,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 = 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 @@ -1844,38 +1699,15 @@ 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, - 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) - -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 sand op func = do + modify $ \funcs -> + let code = uncurry Lambda (op func) + in (Map.insert func (sand, code) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -1883,1279 +1715,378 @@ 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 = 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 arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering $ - mkForeignIOF hGetBuffering + declareForeign Tracked argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering - . mkForeignIOF - $ uncurry hSetBuffering + declareForeign Tracked arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked "IO.setEcho.impl.v1" set'echo . mkForeignIOF $ uncurry hSetEcho + declareForeign Tracked argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked "IO.getLine.impl.v1" argToEF $ - mkForeignIOF $ - fmap Util.Text.fromText . Text.IO.hGetLine + declareForeign Tracked (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGet h n + declareForeign Tracked arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGetSome h n + declareForeign Tracked (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + declareForeign Tracked argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked "IO.systemTime.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> getPOSIXTime + declareForeign Tracked (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR $ - mkForeign $ - \() -> fmap (1e6 *) getPOSIXTime + declareForeign Tracked arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Monotonic - - declareForeign Tracked "Clock.internals.realtime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Realtime - - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ProcessCPUTime - - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ThreadCPUTime - - declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) - - -- 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) - ) - - let chop = reverse . dropWhile isPathSeparator . reverse - - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> chop <$> getTemporaryDirectory +declareForeigns :: FDecl Symbol () +declareForeigns = do + declareUdpForeigns + declareForeign Tracked argIomrToEF IO_openFile_impl_v3 - declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF $ - mkForeignIOF $ \prefix -> do - temp <- getTemporaryDirectory - chop <$> createTempDirectory temp prefix + 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.getCurrentDirectory.impl.v3" unitToEF - . mkForeignIOF - $ \() -> getCurrentDirectory + declareForeign Tracked seek'handle IO_seekHandle_impl_v3 - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 $ - mkForeignIOF setCurrentDirectory + declareForeign Tracked argToEFNat IO_handlePosition_impl_v3 - declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool $ - mkForeignIOF doesPathExist + declareForeign Tracked get'buffering IO_getBuffering_impl_v3 - declareForeign Tracked "IO.getEnv.impl.v1" argToEF $ - mkForeignIOF getEnv + declareForeign Tracked set'buffering IO_setBuffering_impl_v3 - declareForeign Tracked "IO.getArgs.impl.v1" unitToEF $ - mkForeignIOF $ - \() -> fmap Util.Text.pack <$> SYS.getArgs + declareForeign Tracked set'echo IO_setEcho_impl_v1 - declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool $ - mkForeignIOF doesDirectoryExist + declareForeign Tracked argToEF IO_getLine_impl_v1 - declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 $ - mkForeignIOF $ - createDirectoryIfMissing True + 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.removeDirectory.impl.v3" argToEF0 $ - mkForeignIOF removeDirectoryRecursive + declareForeign Tracked unitToR IO_systemTimeMicroseconds_v1 - declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameDirectory + declareForeign Tracked unitToEF Clock_internals_monotonic_v1 - declareForeign Tracked "IO.directoryContents.impl.v3" argToEF $ - mkForeignIOF $ - (fmap Util.Text.pack <$>) . getDirectoryContents + declareForeign Tracked unitToEF Clock_internals_realtime_v1 - declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 $ - mkForeignIOF removeFile + declareForeign Tracked unitToEF Clock_internals_processCPUTime_v1 - declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameFile + declareForeign Tracked unitToEF Clock_internals_threadCPUTime_v1 - declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat - . mkForeignIOF - $ fmap utcTimeToPOSIXSeconds . getModificationTime + declareForeign Tracked (argNDirect 1) Clock_internals_sec_v1 - declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \fp -> fromInteger @Word64 <$> getFileSize fp + -- A TimeSpec that comes from getTime never has negative nanos, + -- so we can safely cast to Nat + declareForeign Tracked (argNDirect 1) Clock_internals_nsec_v1 - declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF - . mkForeignIOF - $ \( mhst :: Maybe Util.Text.Text, - port - ) -> - fst <$> SYS.bindSock (hostPreference mhst) port + declareForeign Tracked time'zone Clock_internals_systemTimeZone_v1 - declareForeign Tracked "Socket.toText" (argNDirect 1) - . mkForeign - $ \(sock :: Socket) -> pure $ show sock + declareForeign Tracked unitToEF IO_getTempDirectory_impl_v3 - declareForeign Tracked "Handle.toText" (argNDirect 1) - . mkForeign - $ \(hand :: Handle) -> pure $ show hand + declareForeign Tracked argToEF IO_createTempDirectory_impl_v3 - declareForeign Tracked "ThreadId.toText" (argNDirect 1) - . mkForeign - $ \(threadId :: ThreadId) -> pure $ show threadId + declareForeign Tracked unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat - . mkForeignIOF - $ \(handle :: Socket) -> do - n <- SYS.socketPort handle - return (fromIntegral n :: Word64) + declareForeign Tracked argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked "IO.listen.impl.v3" argToEF0 - . mkForeignIOF - $ \sk -> SYS.listenSock sk 2048 + declareForeign Tracked argToEFBool IO_fileExists_impl_v3 - declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF - . mkForeignIOF - $ fmap fst . uncurry SYS.connectSock + declareForeign Tracked argToEF IO_getEnv_impl_v1 - declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 $ - mkForeignIOF SYS.closeSock + declareForeign Tracked unitToEF IO_getArgs_impl_v1 - declareForeign Tracked "IO.socketAccept.impl.v3" argToEF - . mkForeignIOF - $ fmap fst . SYS.accept + declareForeign Tracked argToEFBool IO_isDirectory_impl_v3 - declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + declareForeign Tracked argToEF0 IO_createDirectory_impl_v3 - declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF - . mkForeignIOF - $ \(hs, n) -> - maybe mempty Bytes.fromArray <$> SYS.recv hs n + declareForeign Tracked argToEF0 IO_removeDirectory_impl_v3 - declareForeign Tracked "IO.kill.impl.v3" argToEF0 $ mkForeignIOF killThread + declareForeign Tracked arg2ToEF0 IO_renameDirectory_impl_v3 - let mx :: Word64 - mx = fromIntegral (maxBound :: Int) + declareForeign Tracked argToEF IO_directoryContents_impl_v3 - customDelay :: Word64 -> IO () - customDelay n - | n < mx = threadDelay (fromIntegral n) - | otherwise = threadDelay maxBound >> customDelay (n - mx) + declareForeign Tracked argToEF0 IO_removeFile_impl_v3 - declareForeign Tracked "IO.delay.impl.v3" argToEFUnit $ - mkForeignIOF customDelay + declareForeign Tracked arg2ToEF0 IO_renameFile_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 argToEFNat IO_getFileTimestamp_impl_v3 - let exitDecode ExitSuccess = 0 - exitDecode (ExitFailure n) = n + declareForeign Tracked argToEFNat IO_getFileSize_impl_v3 - declareForeign Tracked "IO.process.call" (argNDirect 2) . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - withCreateProcess (proc exe args) $ \_ _ _ p -> - exitDecode <$> waitForProcess p + declareForeign Tracked maybeToEF IO_serverSocket_impl_v3 - declareForeign Tracked "IO.process.start" start'process . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - runInteractiveProcess exe args Nothing Nothing + declareForeign Tracked (argNDirect 1) Socket_toText - declareForeign Tracked "IO.process.kill" argToUnit . mkForeign $ - terminateProcess - - declareForeign Tracked "IO.process.wait" (argNDirect 1) . mkForeign $ - \ph -> exitDecode <$> waitForProcess ph - - declareForeign Tracked "IO.process.exitCode" argToMaybe . mkForeign $ - fmap (fmap exitDecode) . getProcessExitCode + declareForeign Tracked (argNDirect 1) Handle_toText - declareForeign Tracked "MVar.new" (argNDirect 1) - . mkForeign - $ \(c :: Val) -> newMVar c + declareForeign Tracked (argNDirect 1) ThreadId_toText - declareForeign Tracked "MVar.newEmpty.v2" unitDirect - . mkForeign - $ \() -> newEmptyMVar @Val + declareForeign Tracked argToEFNat IO_socketPort_impl_v3 - declareForeign Tracked "MVar.take.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> takeMVar mv + declareForeign Tracked argToEF0 IO_listen_impl_v3 - declareForeign Tracked "MVar.tryTake" argToMaybe - . mkForeign - $ \(mv :: MVar Val) -> tryTakeMVar mv + declareForeign Tracked arg2ToEF IO_clientSocket_impl_v3 - declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(mv :: MVar Val, x) -> putMVar mv x + declareForeign Tracked argToEF0 IO_closeSocket_impl_v3 - declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool - . mkForeignIOF - $ \(mv :: MVar Val, x) -> tryPutMVar mv x + declareForeign Tracked argToEF IO_socketAccept_impl_v3 - declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF - . mkForeignIOF - $ \(mv :: MVar Val, x) -> swapMVar mv x + declareForeign Tracked arg2ToEF0 IO_socketSend_impl_v3 - declareForeign Tracked "MVar.isEmpty" (argNDirect 1) - . mkForeign - $ \(mv :: MVar Val) -> isEmptyMVar mv + declareForeign Tracked arg2ToEF IO_socketReceive_impl_v3 - declareForeign Tracked "MVar.read.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> readMVar mv + declareForeign Tracked argToEF0 IO_kill_impl_v3 - declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM - . mkForeignIOF - $ \(mv :: MVar Val) -> tryReadMVar mv + declareForeign Tracked argToEFUnit IO_delay_impl_v3 - declareForeign Untracked "Char.toText" (argNDirect 1) . mkForeign $ - \(ch :: Char) -> pure (Util.Text.singleton ch) + declareForeign Tracked standard'handle IO_stdHandle - declareForeign Untracked "Text.repeat" (argNDirect 2) . mkForeign $ - \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + declareForeign Tracked (argNDirect 2) IO_process_call - declareForeign Untracked "Text.reverse" (argNDirect 1) . mkForeign $ - pure . Util.Text.reverse + declareForeign Tracked start'process IO_process_start - declareForeign Untracked "Text.toUppercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUppercase + declareForeign Tracked argToUnit IO_process_kill - declareForeign Untracked "Text.toLowercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toLowercase + declareForeign Tracked (argNDirect 1) IO_process_wait - declareForeign Untracked "Text.toUtf8" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUtf8 + declareForeign Tracked argToMaybe IO_process_exitCode + declareForeign Tracked (argNDirect 1) MVar_new - declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF . mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + declareForeign Tracked unitDirect MVar_newEmpty_v2 - 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 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 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 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 arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign Tracked "TVar.new" (argNDirect 1) . mkForeign $ - \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + declareForeign Tracked arg2ToEF MVar_swap_impl_v3 - declareForeign Tracked "TVar.read" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + declareForeign Tracked (argNDirect 1) MVar_isEmpty - declareForeign Tracked "TVar.write" arg2To0 . mkForeign $ - \(v :: STM.TVar Val, c :: Val) -> - unsafeSTMToIO $ STM.writeTVar v c + declareForeign Tracked argToEF MVar_read_impl_v3 - declareForeign Tracked "TVar.newIO" (argNDirect 1) . mkForeign $ - \(c :: Val) -> STM.newTVarIO c + declareForeign Tracked argToEFM MVar_tryRead_impl_v3 - declareForeign Tracked "TVar.readIO" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> STM.readTVarIO v + 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 "TVar.swap" (argNDirect 2) . mkForeign $ - \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign Tracked "STM.retry" unitDirect . mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Val + declareForeign Tracked (argNDirect 1) TVar_new - declareForeign Tracked "Promise.new" unitDirect . mkForeign $ - \() -> newPromise @Val + declareForeign Tracked (argNDirect 1) TVar_read + declareForeign Tracked arg2To0 TVar_write + declareForeign Tracked (argNDirect 1) TVar_newIO + 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) . mkForeign $ - \(p :: Promise Val) -> readPromise p - - 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 $ - \( 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 (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 - 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 - -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 - -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 - 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 = - execState (runReaderT declareForeigns sanitize) (0, [], mempty) + 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 | (_, l, _) <- foreignDeclResults False = reverse l +foreignWrappers = + Map.toList foreignDeclResults + <&> \(ff, (sand, code)) -> (foreignFuncBuiltinName ff, (sand, code)) numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -3169,14 +2100,12 @@ 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 :: EnumMap Word64 Data.Text.Text -builtinForeignNames | (_, _, m) <- foreignDeclResults False = fst <$> m +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 @@ -3198,5 +2127,7 @@ 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 +sandboxedForeignFuncs :: Set ForeignFunc +sandboxedForeignFuncs = + Map.keysSet $ + Map.filter (\(sb, _) -> sb == Tracked) foreignDeclResults diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 71808e9ab3..335d9ff61d 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -8,9 +8,7 @@ {-# LANGUAGE ViewPatterns #-} module Unison.Runtime.Foreign.Function - ( ForeignFunc (..), - ForeignConvention (..), - mkForeign, + ( ForeignConvention (..), ) where @@ -24,7 +22,6 @@ import Data.IORef (IORef) import Data.Sequence qualified as Sq import Data.Time.Clock.POSIX (POSIXTime) import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Base (IO (..)) import GHC.IO.Exception (IOErrorType (..), IOException (..)) import Network.Socket (Socket) import Network.UDP (UDPSocket) @@ -35,7 +32,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, @@ -53,47 +49,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 :: - (XStack -> Args -> IO a) -> - (XStack -> r -> IOStack) -> - (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 :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeign ev = FF readArgs doWrite ev - where - doWrite :: XStack -> r -> IOStack - doWrite stk a = case writeForeign (packXStack stk) a of - (IO f) -> \state -> case f state of - (# state', stk #) -> (# state', unpackXStack stk #) - readArgs (packXStack -> 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/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 new file mode 100644 index 0000000000..e924243759 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs @@ -0,0 +1,1277 @@ +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.Safe qualified as Exception +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Primitive qualified as PA +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.PEM (PEM, pemContent, pemParseLBS) +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.Builtin.Decls qualified as Ty +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Referent (Referent, pattern Ref) +import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.ANF.Rehash (checkGroupHashes) +import Unison.Runtime.ANF.Serialize qualified as ANF +import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin +import Unison.Runtime.Crypto.Rsa qualified as Rsa +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 +import Unison.Type qualified as Ty +import Unison.Util.Bytes qualified as Bytes +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 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 -> F.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 -> + 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, ANF.Code)]) -> do + let f (msg, rs) = + F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs + pure . first f $ checkGroupHashes lsgs0 + Code_dependencies -> mkForeign $ + \(ANF.CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg + Code_serialize -> mkForeign $ + \(co :: ANF.Code) -> + pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co + Code_deserialize -> + mkForeign $ + pure . ANF.deserializeCode . Bytes.toArray + Code_display -> mkForeign $ + \(nm, (ANF.CodeRep sg _)) -> + pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" + Value_dependencies -> + mkForeign $ + pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks + Value_serialize -> + mkForeign $ + pure . Bytes.fromArray . ANF.serializeValue + Value_deserialize -> + mkForeign $ + 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 + 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 $ ANF.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 $ ANF.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 . ANF.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 + + 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 + + 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 +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 $ F.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 (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 Failure r)) -> + Args -> + Stack -> + IO Stack +mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) + tryIO1 = UnliftIO.try + 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 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)) diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index 33619b22b0..3f2ba86f83 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -120,6 +120,7 @@ import Unison.Runtime.MCode emitComb, emptyRNs, resolveCombs, + sanitizeCombs, ) import Unison.Runtime.MCode.Serialize import Unison.Runtime.Machine @@ -1255,9 +1256,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. @@ -1319,10 +1320,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 builtinForeigns False debugText + CCache sandboxed debugText <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO (crs <> builtinTermBackref) @@ -1336,6 +1337,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 @@ -1369,6 +1371,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 b307c8a935..ee3a682858 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -38,6 +38,7 @@ module Unison.Runtime.MCode emitCombs, emitComb, resolveCombs, + sanitizeCombs, absurdCombs, emptyRNs, argsToLists, @@ -59,7 +60,9 @@ 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.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text import Data.Void (Void, absurd) import Data.Word (Word16, Word64) import GHC.Stack (HasCallStack) @@ -92,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) @@ -253,6 +257,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 @@ -497,11 +504,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. + | -- Call out to a Haskell function. ForeignCall !Bool -- catch exceptions - !Word64 -- FFI call + !ForeignFunc -- FFI call !Args -- arguments | -- Set the value of a dynamic reference SetDyn @@ -537,6 +543,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 @@ -1393,8 +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.FOp -> Args -> Instr -emitFOp fop = ForeignCall True (fromIntegral $ fromEnum fop) +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 @@ -1797,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 5d35608810..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,6 +55,13 @@ getComb = Lam <$> gInt <*> gInt <*> getSection CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" +getMForeignFunc :: (MonadGet m) => m ForeignFunc +getMForeignFunc = do + toEnum <$> gInt + +putMForeignFunc :: (MonadPut m) => ForeignFunc -> m () +putMForeignFunc = pInt . fromEnum + data SectionT = AppT | CallT @@ -161,6 +169,7 @@ data InstrT | SeqT | TryForceT | RefCAST + | SandboxingFailureT instance Tag InstrT where tag2word UPrim1T = 0 @@ -181,6 +190,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 +210,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 +220,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 +233,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 +245,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 +258,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 fa73ea66e6..9356bd4dc0 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -43,11 +43,11 @@ import Data.Set qualified as Set import Data.Text qualified as DTx import Data.Text.IO qualified as Tx import Data.Traversable -import GHC.Base (IO (..)) import GHC.Conc as STM (unsafeIOToSTM) import GHC.Stack 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 @@ -72,10 +72,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.Exception (RuntimeExn (..)) +import Unison.Runtime.Builtin hiding (unitValue) +import Unison.Runtime.Exception hiding (die) import Unison.Runtime.Foreign -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 @@ -137,8 +137,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), @@ -169,7 +168,7 @@ refNumTm cc r = baseCCache :: Bool -> IO CCache baseCCache sandboxed = do - CCache ffuncs sandboxed noTrace + CCache sandboxed noTrace <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO builtinTermBackref @@ -183,7 +182,6 @@ baseCCache sandboxed = do <*> newTVarIO baseSandboxInfo where cacheableCombs = mempty - ffuncs | sandboxed = sandboxedForeigns | otherwise = builtinForeigns noTrace _ _ = NoTrace ftm = 1 + maximum builtinTermNumbering fty = 1 + maximum builtinTypeNumbering @@ -198,6 +196,7 @@ baseCCache sandboxed = do combs :: EnumMap Word64 MCombs combs = srcCombs + & sanitizeCombs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing @@ -281,8 +280,13 @@ apply1 callback env threadTracker clo = do where k0 = CB $ Hook (\stk -> callback $ packXStack stk) -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 #-} litToVal :: MLit -> Val litToVal = \case @@ -478,8 +482,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 @@ -551,17 +555,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 @@ -585,14 +591,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) = do - let xStack = unpackXStack stk - r <- arg (unpackXStack stk) args >>= ev - IO $ \s -> case res xStack r s of - (# s, xstk #) -> (# s, (denv, packXStack xstk, k) #) - | otherwise = - die $ "reference to unknown foreign function: " ++ show w +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 @@ -615,6 +615,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 :: @@ -640,22 +642,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) -- | Evaluate a section eval :: @@ -1511,36 +1513,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 @@ -1552,7 +1555,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 @@ -1564,7 +1567,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, @@ -1580,7 +1583,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, @@ -1593,7 +1596,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 @@ -1604,7 +1607,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 @@ -1616,7 +1619,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 @@ -1628,7 +1631,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 @@ -1637,7 +1640,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 @@ -1646,7 +1649,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 @@ -1656,18 +1659,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 @@ -1680,13 +1683,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. @@ -1695,13 +1698,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 @@ -1709,15 +1714,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 :: @@ -1917,7 +1922,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 @@ -2225,7 +2230,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 0477ee1bf5..ba2bc42b9c 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -48,6 +48,8 @@ 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 Unison.Runtime.Machine