A-gent-0.11.0.3: src/Agent/IO/Restricted.hs
{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2026 SPISE MISU ApS
-- License : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability : experimental
--
-- Safe {H}askell
--
-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html
--
-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12:
-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen,
-- Denmark, ACM, 2012
--
-- Though Haskell is predominantly type-safe, implementations contain a few
-- loopholes through which code can bypass typing and module encapsulation. This
-- paper presents Safe Haskell, a language extension that closes these
-- loopholes. Safe Haskell makes it possible to confine and safely execute
-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell
-- allows a variety of different policies from API sandboxing to
-- information-flow control to be implemented easily as monads. Safe Haskell is
-- aimed to be as unobtrusive as possible. It enforces properties that
-- programmers tend to meet already by convention. We describe the design of
-- Safe Haskell and an implementation (currently shipping with GHC) that infers
-- safety for code that lies in a safe subset of the language. We use Safe
-- Haskell to implement an online Haskell interpreter that can securely execute
-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly
-- simplifies this task and allows the use of a large body of existing code and
-- tools.
--------------------------------------------------------------------------------
module Agent.IO.Restricted
( RIO ()
, run
-- * Environment
, getEnvVar
-- * Read/Print
, input
, output
-- * LLM (Chat)
, llmChatKey, llmChatAPI
, llmChatCurl
-- * LLM (Code)
)
where
--------------------------------------------------------------------------------
import qualified System.Environment.Blank as ENV
import System.IO
{-
( hFlush, hPutStr, stdout
, hSetEncoding
, utf8
)
-}
( hFlush, stdout
, hReady, stdin
)
import System.Exit
( ExitCode
( ExitFailure
, ExitSuccess
)
)
import System.Process
( readProcessWithExitCode
)
import qualified Agent.IO.Effects as EFF
--------------------------------------------------------------------------------
newtype RIO a = RestrictedIO { run :: IO a }
instance Functor RIO where
fmap f m = RestrictedIO $ f <$> run m
instance Applicative RIO where
pure = RestrictedIO . pure
(<*>) f m = RestrictedIO $ run f <*> run m
instance Monad RIO where
(>>=) m f = RestrictedIO $ run m >>= run . f
--------------------------------------------------------------------------------
class StdIn m where
input :: m String
class StdOut m where
output :: String -> m ()
instance StdIn RIO where
input =
RestrictedIO $ aux [] []
where
aux bcs acs =
key >>= \ k ->
case k of
-- NOTE: To view keystrokes, use: `ghc -e getLine` (hit + ENTER)
'\008':[] ->
case bcs of
-- NOTE: Backspace (remove char if any and re-write after chars)
[ ] -> aux bcs acs
(_:cs) ->
putChar '\008' >> hFlush stdout >>
putChar '\032' >> hFlush stdout >>
putStr es >> hFlush stdout >>
putStr rm >> hFlush stdout >>
putChar '\008' >> hFlush stdout >>
putStr acs >> hFlush stdout >>
putStr rm >> hFlush stdout >>
aux cs acs
where
lc = length acs
es = concatMap id $ take lc $ repeat sp
rm = concatMap id $ take lc $ repeat la
sp = [ ' ' ]
la = [ '\ESC', '[', 'D' ]
'\010':[] ->
-- NOTE: Enter
pure $ (++ acs) $ reverse $ bcs
'\ESC':'[':'C':[] ->
-- NOTE: Allowed escaped sequences: Arrow "->"
case (bcs, acs) of
(_, [ ]) ->
aux bcs acs
(_, c:cs) ->
putStr k >> hFlush stdout >>
aux (c:bcs) cs
'\ESC':'[':'D':[ ] ->
-- NOTE: Allowed escaped sequences: Arrow "<-"
case (bcs, acs) of
([ ], _) ->
aux bcs acs
(c:cs, _) ->
putStr k >> hFlush stdout >>
aux cs (c:acs)
'\ESC':'[':'H':[] ->
-- NOTE: HOME
putStr rm >> hFlush stdout >>
(aux [] ((reverse bcs) ++ acs))
where
lc = length bcs
rm = concatMap id $ take lc $ repeat la
la = [ '\ESC', '[', 'D' ]
'\ESC':'[':'1':';':'5':'C':[] ->
-- NOTE: Allowed escaped sequences: CTRL + Arrow "->"
putStr rm >> hFlush stdout >>
(aux (ts ++ bcs) ds)
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') acs
ts = drop (length ds) $ reverse acs
lc = length ts
rm = concatMap id $ take lc $ repeat la
la = [ '\ESC', '[', 'C' ]
'\ESC':'[':'1':';':'5':'D':[] ->
-- NOTE: Allowed escaped sequences: CTRL + Arrow "<-"
putStr rm >> hFlush stdout >>
(aux ds (ts ++ acs))
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') bcs
ts = drop (length ds) $ reverse bcs
lc = length ts
rm = concatMap id $ take lc $ repeat la
la = [ '\ESC', '[', 'D' ]
'\ESC':'[':'F':[] ->
-- NOTE: END
putStr rm >> hFlush stdout >>
(aux ((++ bcs) $ reverse $ acs) [])
where
lc = length acs
rm = concatMap id $ take lc $ repeat la
la = [ '\ESC', '[', 'C' ]
'\ESC':'[':'3':'~':[] ->
case acs of
-- NOTE: Delete (remove char if any and re-write after chars)
[ ] -> aux bcs acs
(_:cs) ->
putStr cs >> hFlush stdout >>
putChar ' ' >> hFlush stdout >>
putStr rm >> hFlush stdout >>
(aux bcs cs)
where
lc = length acs
rm = concatMap id $ take lc $ repeat la
la = [ '\ESC', '[', 'D' ]
'\ESC':__ ->
-- NOTE: Other escaped sequences (skip)
aux bcs acs
'\DEL':[] ->
-- NOTE: DELETE (skip)
aux bcs acs
_________ ->
putStr k >> hFlush stdout >>
putStr acs >> hFlush stdout >>
putStr rm >> hFlush stdout >>
(aux (reverse k ++ bcs) acs)
where
lc = length acs
rm = concatMap id $ take lc $ repeat la
la = ['\ESC','[','D']
key =
-- NOTE: https://stackoverflow.com/a/38553473
reverse <$> nxt []
where
nxt cs =
do
c <- getChar
m <- hReady stdin
(if m then nxt else pure) (c:cs)
instance StdOut RIO where
output x = RestrictedIO $
{- BUG: Emojis can't be printed to console (UTF-16 "surrogate pairs")
<stdout>: hPutChar: invalid argument (cannot encode character '\55357'
hSetEncoding stdout utf8 >>
hPutStr stdout x >>
hFlush stdout
-}
putStr x >> hFlush stdout
--------------------------------------------------------------------------------
class SysEnv m where
getEnvVar :: String -> m (Maybe String)
instance SysEnv RIO where
getEnvVar = RestrictedIO . ENV.getEnv
--------------------------------------------------------------------------------
class ReadProc m where
withExitCode :: String -> [String] -> m (Either String String)
instance ReadProc RIO where
withExitCode app fs = RestrictedIO $
do
(exitcode, out, err) <- readProcessWithExitCode app fs []
case exitcode of
ExitSuccess ->
return $ Right out
ExitFailure _ ->
return $ Left err
--------------------------------------------------------------------------------
class (EFF.LlmChatConf m, SysEnv m) => LlmChatConf m where
llmChatAPI :: m (Maybe String)
llmChatKey :: m (Maybe String)
instance (EFF.LlmChatConf RIO, SysEnv RIO) => LlmChatConf RIO where
llmChatAPI = getEnvVar "LLM_CHAT_LOCALHOST_API"
llmChatKey = pure Nothing
class (EFF.LlmChatConf m , ReadProc m) => LlmChatCurl m where
llmChatCurl :: String -> m (Either String String)
instance (EFF.LlmChatConf RIO, ReadProc RIO) => LlmChatCurl RIO where
llmChatCurl json =
llmChatAPI >>= \ mapi ->
llmChatKey >>= \ mkey ->
case (mapi, mkey) of
(Nothing, _ ) ->
RestrictedIO $ pure $ Left "No API address was provided"
(Just api, Nothing) ->
( \ case
Right env -> Right env
Left err -> Left err
)
<$> withExitCode "curl"
[ "--silent"
, "--show-error"
, "--header" , "\"Content-Type: application/json; charset=utf-8\""
, "--data" , json
, api ++ "/chat/completions"
]
(Just api, Just key) ->
( \ case
Right env -> Right env
Left err -> Left err
)
<$> withExitCode "curl" -- "echo" --
[ "--silent"
, "--show-error"
, "--header" , "\"Authorization: \"" ++ key ++ "\" "
, "--header" , "\"Content-Type: application/json; charset=utf-8\""
, "--data" , json
, api ++ "/chat/completions"
]