A-gent-0.11.0.6: src/Agent/IO/Restricted.hs
{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
-- |
-- 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 (Config)
, llmPathCWD
-- * LLM (Chat)
, llmChatKey, llmChatAPI
, llmChatWeb
-- * LLM (Code)
, llmCodeDir
, llmCodeMsk
, llmCodeSeq, llmCodeGet
-- * LLM (Plan)
, llmPlanDir
, llmPlanMsk
, llmPlanSeq, llmPlanGet
, llmPlanKey, llmPlanAPI
, llmPlanWeb
-- * Temporary
, readFileStrict
)
where
--------------------------------------------------------------------------------
import Data.Either ( partitionEithers )
import Data.List ( isInfixOf )
import Data.Maybe ( fromMaybe )
import qualified System.Environment.Blank as ENV
import System.Exit
( ExitCode (ExitFailure, ExitSuccess)
)
import System.IO ( hFlush, hReady, stdin, stdout )
import System.Process
( CreateProcess (cwd)
, proc
, readCreateProcessWithExitCode
, 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
:: [ String ]
-> [ String ]
-> m String
class StdOut m where
output
:: String
-> m ()
--------------------------------------------------------------------------------
instance StdIn RIO where
-- BUG: Issue with multiline text
input prev next =
-- TODO: CTRL+U (erase from cursor to start of line) and CTRL+K (erase from
-- cursor to end of line
RestrictedIO $ aux prev next [] []
where
aux hps hns bcs acs =
key >>= \ k ->
case (k < [ '\32' ], k) of
-- NOTE: To view keystrokes, use: `ghc -e getLine` (hit + ENTER)
(True , '\008':[]) ->
case bcs of
-- NOTE: Backspace (remove char if any and re-write after chars)
[ ] -> aux hps hns 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 hps hns cs acs
where
la = [ '\ESC', '[', 'D' ]
lc = length acs
es = concatMap id $ take lc $ repeat sp
rm = concatMap id $ take lc $ repeat la
sp = [ ' ' ]
(True , '\010':[]) ->
-- NOTE: ENTER (only if something is typed)
case (bcs, acs) of
([], []) ->
aux hps hns bcs acs
________ ->
pure $ (++ acs) $ reverse $ bcs
(True , '\012':[]) ->
-- NOTE: Form Feed becomes "/w" (clear screen)
pure $ "/w"
(True , '\ESC':'[':'A':[]) ->
-- NOTE: Allowed escaped sequences: Arrow "↑"
case (txt, hps, hns) of
(_, [ ], _) -> aux hps hns bcs acs
(_, p:ps, _) ->
putStr rm >> hFlush stdout >>
putStr es >> hFlush stdout >>
putStr rm >> hFlush stdout >>
putStr p >> hFlush stdout >>
aux ps (p:hns) rev []
where
rev = reverse p
where
sp = [ ' ' ]
la = [ '\ESC', '[', 'D' ]
lc = length txt
es = concatMap id $ take lc $ repeat sp
rm = concatMap id $ take lc $ repeat la
txt = (++ acs) $ reverse $ bcs
(True , '\ESC':'[':'B':[]) ->
-- NOTE: Allowed escaped sequences: Arrow "↓"
case (txt, hps, hns) of
(_, _, [ ]) -> aux hps hns bcs acs
(_, _, p:ps) ->
putStr rm >> hFlush stdout >>
putStr es >> hFlush stdout >>
putStr rm >> hFlush stdout >>
putStr p >> hFlush stdout >>
aux (p:hps) ps rev []
where
rev = reverse p
where
sp = [ ' ' ]
la = [ '\ESC', '[', 'D' ]
lc = length txt
es = concatMap id $ take lc $ repeat sp
rm = concatMap id $ take lc $ repeat la
txt = (++ acs) $ reverse $ bcs
(True , '\ESC':'[':'C':[]) ->
-- NOTE: Allowed escaped sequences: Arrow "→"
case (bcs, acs) of
(_, [ ]) ->
aux hps hns bcs acs
(_, c:cs) ->
putStr k >> hFlush stdout >>
aux hps hns (c:bcs) cs
(True , '\ESC':'[':'D':[ ]) ->
-- NOTE: Allowed escaped sequences: Arrow "←"
case (bcs, acs) of
([ ], _) ->
aux hps hns bcs acs
(c:cs, _) ->
putStr k >> hFlush stdout >>
aux hps hns cs (c:acs)
(True , '\ESC':'[':'1':';':'5':'C':[]) ->
-- NOTE: Allowed escaped sequences: CTRL + Arrow "→"
putStr rm >> hFlush stdout >>
(aux hps hns (ts ++ bcs) ds)
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') acs
ts = drop (length ds) $ reverse acs
la = [ '\ESC', '[', 'C' ]
lc = length ts
rm = concatMap id $ take lc $ repeat la
(True , '\ESC':'[':'1':';':'5':'D':[]) ->
-- NOTE: Allowed escaped sequences: CTRL + Arrow "←"
putStr rm >> hFlush stdout >>
(aux hps hns ds (ts ++ acs))
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') bcs
ts = drop (length ds) $ reverse bcs
la = [ '\ESC', '[', 'D' ]
lc = length ts
rm = concatMap id $ take lc $ repeat la
(True , '\ESC':'[':'H':[]) ->
-- NOTE: HOME
-- HERE:
putStr rm >> hFlush stdout >>
(aux hps hns [] ((reverse bcs) ++ acs))
where
la = [ '\ESC', '[', 'D' ]
lc = length bcs
rm = concatMap id $ take lc $ repeat la
(True , '\ESC':'[':'F':[]) ->
-- NOTE: END
putStr rm >> hFlush stdout >>
(aux hps hns ((++ bcs) $ reverse $ acs) [])
where
la = [ '\ESC', '[', 'C' ]
lc = length acs
rm = concatMap id $ take lc $ repeat la
(True , '\ESC':'[':'3':'~':[]) ->
case acs of
-- NOTE: Delete (remove char if any and re-write after chars)
[ ] -> aux hps hns bcs acs
(_:cs) ->
putStr cs >> hFlush stdout >>
putChar ' ' >> hFlush stdout >>
putStr rm >> hFlush stdout >>
(aux hps hns bcs cs)
where
la = [ '\ESC', '[', 'D' ]
lc = length acs
rm = concatMap id $ take lc $ repeat la
(True , '\ESC':__) ->
-- NOTE: Other escaped sequences (skip)
aux hps hns bcs acs
(True , _) ->
-- NOTE: Skip all other unhandled control keys
aux hps hns bcs acs
(False, '\DEL':[]) ->
-- NOTE: DELETE (skip)
aux hps hns bcs acs
(False, _) ->
putStr k >> hFlush stdout >>
putStr acs >> hFlush stdout >>
putStr rm >> hFlush stdout >>
(aux hps hns (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 $
putStr x >> hFlush stdout
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmConf m
where
llmPathCWD
:: m (Maybe String)
instance
EFF.LlmConf RIO
=> LlmConf RIO
where
llmPathCWD = getEnvVar "LLM_PATH_CWD"
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmChatConf m
=> LlmChatConf m
where
llmChatAPI
:: m (Maybe String)
llmChatKey
:: m (Maybe String)
instance
EFF.LlmChatConf RIO
=> LlmChatConf RIO
where
llmChatAPI = getEnvVar "LLM_CHAT_LOCALHOST_API"
llmChatKey = pure Nothing
--------------------------------------------------------------------------------
class
EFF.LlmChatConf m
=> LlmChatPost m
where
llmChatWeb
:: String -> m (Either String String)
instance
EFF.LlmChatConf RIO
=> LlmChatPost RIO
where
llmChatWeb json =
EFF.llmChatAPI >>= \ mapi ->
EFF.llmChatKey >>= \ mkey ->
llmCurl json mapi mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmCodeRoot m
where
llmCodeDir
:: m String
instance
( EFF.LlmConf RIO
, EFF.LlmCodeRoot RIO
)
=> LlmCodeRoot RIO
where
llmCodeDir = pure "src"
--------------------------------------------------------------------------------
class
EFF.LlmCodeMask m
=> LlmCodeMask m
where
llmCodeMsk
:: m [ String ]
instance
( EFF.LlmConf RIO
, EFF.LlmCodeMask RIO
)
=> LlmCodeMask RIO
where
llmCodeMsk = pure [ "*.hs" ]
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeRoot m
, EFF.LlmCodeMask m
)
=> LlmCodeRead m
where
llmCodeSeq
:: Maybe String
-> m (Either String [ String ])
llmCodeGet
:: String
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeRoot RIO
, EFF.LlmCodeMask RIO
)
=> LlmCodeRead RIO
where
llmCodeSeq mfilter =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmCodeDir >>= \ cdir ->
EFF.llmCodeMsk >>= \ cmsk ->
realPath (fromMaybe [] ocwd ++ "/" ++ cdir) >>= \ efrp ->
case efrp of
Right frp ->
( \ case
([], rs) ->
Right $ concat rs
(ls, __) ->
Left $ foldl1 (\ x y -> x ++ "\n" ++ y) ls
)
. partitionEithers
. map
( \ case
Right fns ->
case mfilter of
Nothing -> Right rel
Just fil -> Right $ filter (isInfixOf fil) rel
where
rel = map (cdir ++ ) fns
Left err ->
Left err
)
<$> mapM (findFiles frp) cmsk
Left err ->
pure $ Left err
llmCodeGet relpath =
EFF.llmPathCWD >>= \ ocwd ->
realPath (fromMaybe [] ocwd) >>= \ efrp ->
case efrp of
Right frp ->
Right <$> readFileStrict (frp ++ "/" ++ relpath)
Left err ->
pure $ Left err
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmPlanRoot m
where
llmPlanDir
:: m String
instance
( EFF.LlmConf RIO
, EFF.LlmPlanRoot RIO
)
=> LlmPlanRoot RIO
where
llmPlanDir = pure "llm"
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmPlanMask m
where
llmPlanMsk
:: m [ String ]
instance
( EFF.LlmConf RIO
, EFF.LlmPlanMask RIO
)
=> LlmPlanMask RIO
where
llmPlanMsk = pure [ "plan_*.md" ]
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmPlanRoot m
, EFF.LlmPlanMask m
)
=> LlmPlanRead m
where
llmPlanSeq
:: Maybe String
-> m (Either String [ String ])
llmPlanGet
:: String
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmPlanRoot RIO
, EFF.LlmPlanMask RIO
)
=> LlmPlanRead RIO
where
llmPlanSeq mfilter =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmPlanDir >>= \ pdir ->
EFF.llmPlanMsk >>= \ pmsk ->
realPath (fromMaybe [] ocwd ++ "/" ++ pdir) >>= \ efrp ->
case efrp of
Right frp ->
( \ case
([], rs) ->
Right $ concat rs
(ls, __) ->
Left $ foldl1 (\ x y -> x ++ "\n" ++ y) ls
)
. partitionEithers
. map
( \ case
Right fns ->
case mfilter of
Nothing -> Right rel
Just fil -> Right $ filter (isInfixOf fil) rel
where
rel = map (pdir ++ ) fns
Left err ->
Left err
)
<$> mapM (findFiles frp) pmsk
Left err ->
pure $ Left err
llmPlanGet path =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmPlanDir >>= \ pdir ->
realPath (fromMaybe [] ocwd ++ "/" ++ pdir) >>= \ efrp ->
case efrp of
Right rp ->
if isInfixOf rp path then
Right <$> readFileStrict path
else
pure $ Left $ "File: " ++ path ++ " is not in: " ++ rp
Left err ->
pure $ Left err
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmPlanConf m
)
=> LlmPlanConf m
where
llmPlanAPI
:: m (Maybe String)
llmPlanKey
:: m (Maybe String)
instance
( EFF.LlmConf RIO
, EFF.LlmPlanConf RIO
)
=> LlmPlanConf RIO
where
llmPlanAPI = getEnvVar "LLM_PLAN_LOCALHOST_API"
llmPlanKey = pure Nothing
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmPlanConf m
)
=> LlmPlanPost m
where
llmPlanWeb
:: String
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmPlanConf RIO
)
=> LlmPlanPost RIO
where
llmPlanWeb json =
EFF.llmPathCWD >>= \ ocwd ->
realPath (fromMaybe [] ocwd) >>= \ efrp ->
case efrp of
Right rp ->
gitExist rp >>= \ git ->
if git then
EFF.llmPlanAPI >>= \ mapi ->
EFF.llmPlanKey >>= \ mkey ->
llmCurl json mapi mkey
else
pure $ Left "No GIT repo initialized"
Left err ->
pure $ Left err
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- HELPERS (public)
getEnvVar
:: String
-> RIO (Maybe String)
getEnvVar =
RestrictedIO . ENV.getEnv
--------------------------------------------------------------------------------
-- HELPERS (private)
findFiles
:: String
-> String
-> RIO (Either String [String])
findFiles path mask =
-- NOTE: Remove any '\NUL` from filepaths
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110
( \case
Right str ->
Right
$ map (filter (/= '\NUL'))
$ map (drop (length path)) -- NOTE: Relative paths instead of full
$ lines str
Left err ->
Left err
)
<$> withExitCodeAndCWD path "find"
[ path
, "-name"
, mask
]
gitExist
:: String
-> RIO Bool
gitExist path =
( \case
Right _ -> True
Left _ -> False
)
<$> withExitCodeAndCWD path "git"
[ "status"
]
llmCurl
:: String
-> Maybe String
-> Maybe String
-> RIO (Either String String)
llmCurl json mapi mkey =
case (mapi, mkey) of
(Nothing, _ ) ->
RestrictedIO $ pure $ Left "No API address was provided"
(Just api, Nothing) ->
withExitCode "curl"
( [ "--silent"
, "--show-error"
]
++ hs ++
[ "--data", json
, api ++ "/chat/completions"
]
)
(Just api, Just key) ->
withExitCode "curl"
( [ "--silent"
, "--show-error"
, "--header", "\"Authorization: \"" ++ key ++ "\""
]
++ hs ++
[ "--data", json
, api ++ "/chat/completions"
]
)
where
hs =
[ "--header" , "\"Accept: application/json\""
, "--header" , "\"Accept-Encoding: gzip, deflate, br\""
, "--header" , "\"Content-Type: application/json; charset=utf-8\""
, "--header" , "\"User-Agent: Λ-gent/0.11\""
]
readFileStrict
:: FilePath
-> RIO String
readFileStrict path =
-- NOTE: «Too Many Open Files» error in Linux
--
-- - http://woshub.com/too-many-open-files-error-linux/
RestrictedIO $
readFile path >>= \bs ->
length bs `seq` pure bs
realPath
:: String
-> RIO (Either String String)
realPath path =
-- NOTE: Remove any '\NUL` from filepaths
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110
( \case
Right str -> Right $ filter (/= '\NUL') str
Left err -> Left err
)
<$> withExitCode "realpath"
[ "--canonicalize-existing"
, "--logical"
, "--physical"
-- NOTE: End each output line with NUL, not newline
, "--zero"
, path
]
withExitCode
:: String
-> [String]
-> RIO (Either String String)
withExitCode cmd args =
RestrictedIO $
do
(exitcode, out, err) <- readProcessWithExitCode cmd args []
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
withExitCodeAndCWD
:: String
-> String
-> [String]
-> RIO (Either String String)
withExitCodeAndCWD path cmd args =
RestrictedIO $
do
(exitcode, out, err) <- readCreateProcessWithExitCode rcp []
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
where
raw = proc cmd args
rcp = raw { cwd = Just path }