A-gent-0.11.0.7: 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
)
where
--------------------------------------------------------------------------------
import Data.Either ( partitionEithers )
import Data.List ( isInfixOf )
import Data.Maybe ( fromMaybe, maybeToList )
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 Text.Read ( readMaybe )
import qualified Agent.IO.Effects as EFF
import qualified Agent.Utils.Common as COM
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
data Position =
Position Int Int
deriving (Eq, Show)
instance Ord Position where
(<=) (Position y1 x1) (Position y2 x2) =
case compare y1 y2 of
GT -> False
EQ -> x1 <= x2
LT -> True
instance Read Position where
readsPrec _ str =
-- NOTE:
-- "\ESC[#;#R" => "\ESC" and "[#;#R" (only parse last)
maybeToList
( readMaybe (f str) >>= \ y ->
readMaybe (g str) >>= \ x ->
Just
( Position y x
, h str
)
)
where
f = takeWhile (/= ';') . drop 1 . dropWhile (/= '[')
g = takeWhile (/= 'R') . drop 1 . dropWhile (/= ';')
h = drop 1 . dropWhile (/= 'R') . dropWhile (/= ';') . dropWhile (/= '[')
--------------------------------------------------------------------------------
data MultiLine =
MultiLine
{ stx :: Maybe Position
, cur :: Maybe Position
, etx :: Maybe Position
, col :: Int
}
deriving Show
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
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 =
-- NOTE: "\ESC7" - save cursor position (SCO)
-- - https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797#cursor-controls
RestrictedIO $ putStr "\ESC7" >> aux gen prev next [] []
where
msv = 32767 :: Int
gen =
MultiLine
{ stx = Nothing
, cur = Nothing
, etx = Nothing
, col = 0
}
aux mlp hps hns bcs acs =
key >>= \ k ->
case (k < ['\32'], k) of
(True , ['\^H']) ->
case bcs of
-- NOTE: CTRL + H or Backspace (remove char if any and re-write
-- after chars)
[ ] -> aux mlp hps hns bcs acs
(_:cs) ->
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Remove char
putChar '\^H' >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns cs acs
(True , ['\^J']) ->
-- NOTE: ENTER (line feed) only if something is typed
case (bcs, acs) of
([], []) ->
aux mlp hps hns bcs acs
________ ->
pure $ (++ acs) $ reverse $ bcs
(True , ['\^L']) ->
-- NOTE: CTRL + L (form feed) becomes "/w" (clear screen)
pure $ "/wipe"
(True , ['\^U']) ->
-- NOTE: CTRL + U cut text to start
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Go back to start of line
putStr hom >> hFlush stdout >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns [] acs
where
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\ESC8"
(True , ['\^K']) ->
-- NOTE: CTRL + K cut text to end
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns bcs []
(True , ['\ESC','[','H']) ->
-- NOTE: HOME
--
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mln hps hns [] (reverse bcs ++ acs)
where
(mln, hom) =
case mlp of
MultiLine { stx = Just (Position y x) } ->
( mlp { cur = Just (Position y x) }
, "\ESC[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, "\ESC8"
)
(True , ['\ESC','[','F']) ->
-- NOTE: END
--
-- NOTE: Move to end of text
hFlush stdout >>
putStr hom >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mln hps hns ((++ bcs) $ reverse $ acs) []
where
(mln, hom) =
case mlp of
MultiLine { etx = Just (Position y x) } ->
( mlp { cur = Just (Position y x) }
, "\ESC[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, "\ESC8"
)
(True , ['\^A']) ->
-- NOTE: CTRL + A to move to start of text
--
-- TODO: DRY as equal to HOME
-- NOTE: Move to start of text
hFlush stdout >>
putStr hom >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mln hps hns [] ((reverse bcs) ++ acs)
where
(mln, hom) =
case mlp of
MultiLine { stx = Just (Position y x) } ->
( mlp { cur = Just (Position y x) }
, "\ESC[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, "\ESC8"
)
(True , ['\^E']) ->
-- NOTE: CTRL + E to move to end of text
--
-- TODO: DRY as equal to END
-- NOTE: Move to end of text
hFlush stdout >>
putStr hom >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mln hps hns ((++ bcs) $ reverse acs) []
where
(mln, hom) =
case mlp of
MultiLine { etx = Just (Position y x) } ->
( mlp { cur = Just (Position y x) }
, "\ESC[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, "\ESC8"
)
(True , ['\ESC','[','A']) ->
-- NOTE: Allowed escaped sequences: Arrow "↑"
case (hps, hns) of
([ ], _) -> aux mlp hps hns bcs acs
(p:ps, _) ->
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Print previous line
putStr p >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr [] >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp ps (p:hns) rev []
where
rev = reverse p
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\ESC8"
(True , ['\ESC','[','B']) ->
-- NOTE: Allowed escaped sequences: Arrow "↓"
case (hps, hns) of
(_, [ ]) -> aux mlp hps hns bcs acs
(_, p:ps) ->
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Print previous line
putStr p >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr [] >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp (p:hps) ps rev []
where
rev = reverse p
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\ESC8"
(True , ['\ESC','[','C']) ->
-- NOTE: Allowed escaped sequences: Arrow "→"
case (bcs, acs) of
(_, [ ]) ->
aux mlp hps hns bcs acs
(_, c:cs) ->
hFlush stdout >>
( if pl then
putStr ("\ESC[" ++ "1" ++ "E")
else
putStr k
) >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns (c:bcs) cs
where
pl =
case mlp of
MultiLine
{ cur = Just (Position cy cx)
, etx = Just (Position ey __)
, col = cw
} -> cy <= ey && cx == cw
___ -> False
(True , ['\ESC','[','D']) ->
-- NOTE: Allowed escaped sequences: Arrow "←"
case (bcs, acs) of
([ ], _) ->
aux mlp hps hns bcs acs
(c:cs, _) ->
hFlush stdout >>
( if pl then
putStr ("\ESC[" ++ "1" ++ "F") >>
putStr ("\ESC[" ++ show msv ++ "C")
else
putStr k
) >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns cs (c:acs)
where
pl =
case mlp of
MultiLine
{ stx = Just (Position sy __)
, cur = Just (Position cy 01)
} -> sy < cy
___ -> False
(True , ['\ESC','[','1',';','5','C']) ->
-- NOTE: Allowed escaped sequences: CTRL + Arrow "→"
-- NOTE: Move to end of text
hFlush stdout >>
putStr np >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns (ts ++ bcs) ds
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') acs
ts = drop (length ds) $ reverse acs
lc = length ts
np =
case mlp of
MultiLine
{ cur = Just (Position cy cx)
, etx = Just (Position ey _ )
, col = cw
} ->
case (cy < ey, compare (cw - cx) lc) of
(True, LT) ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy + 1
x = lc - (cw - cx)
__________ ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy
x = cx + lc
___ -> []
(True , ['\ESC','[','1',';','5','D']) ->
-- NOTE: Allowed escaped sequences: CTRL + Arrow "←"
hFlush stdout >>
putStr np >>
-- NOTE: Update current position
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns ds (ts ++ acs)
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') bcs
ts = drop (length ds) $ reverse bcs
lc = length ts
np =
case mlp of
MultiLine
{ stx = Just (Position sy _ )
, cur = Just (Position cy cx)
, col = cw
} ->
case (sy < cy, compare cx lc) of
(True, LT) ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy - 1
x = cw - (lc - cx)
__________ ->
"\ESC[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy
x = cx - lc
___ -> []
(True , ['\ESC','[','3','~']) ->
-- NOTE: CTRL + D behave as delete key
-- TODO: Use DRY
case acs of
-- NOTE: Delete (remove char if any and re-write after chars)
[ ] -> aux mlp hps hns bcs acs
(_:cs) ->
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr cs >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns bcs cs
(True , ['\^D']) ->
-- NOTE: CTRL + D behave as delete key
-- TODO: Use DRY
case acs of
-- NOTE: Delete (remove char if any and re-write after chars)
[ ] -> aux mlp hps hns bcs acs
(_:cs) ->
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr cs >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns bcs cs
(True , '\ESC':ps) ->
-- NOTE: Other escaped sequences (skip unless positions)
aux mln hps hns bcs acs
where
ops = map readMaybe $ COM.split '\ESC' ps :: [Maybe Position]
mln =
-- NOTE: 0) Print "\ESC[6n" position before action (unused)
-- NOTE: 1) Print "\ESC[6n" end position after action
-- NOTE: 2) Print "\ESC[6n" column witdh
-- NOTE: 3) Print "\ESC[6n" current position after action
case (mlp, ops) of
(___________________________,
[ ]) ->
mlp
(MultiLine { stx = Nothing },
[Just (Position y x) ]) ->
mlp
{ stx = Just sp
, cur = Just sp
, etx = Just sp
, col = x
}
where
sp = Position y x
(MultiLine { etx = Just ep },
[Just cp ]) ->
if cp > ep then
mlp
{ cur = Just cp
, etx = Just cp
}
else
mlp
{ cur = Just cp
}
(MultiLine { stx = Nothing },
[Just sp,Just ep,Just (Position _ w),Just cp]) ->
mlp
{ stx = Just sp
, cur = Just cp
, etx = Just ep
, col = w
}
(___________________________,
[Just __,Just ep,Just (Position _ w),Just cp]) ->
mlp
{ cur = Just cp
, etx = Just ep
, col = w
}
_______________________________________________ ->
mlp
(True , _) ->
aux mlp hps hns bcs acs
(False, ['\DEL']) ->
-- NOTE: DELETE (skip)
aux mlp hps hns bcs acs
(False, _) ->
hFlush stdout >>
-- NOTE: 0) Print "\ESC[6n" position before action
putStr "\ESC[6n" >>
-- NOTE: Type key or text
putStr k >>
-- NOTE: Save position
putStr "\ESC7" >>
-- NOTE: Clear rest of screen from position
putStr "\ESC[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\ESC[6n" end position after action
putStr "\ESC[6n" >>
-- NOTE: 2) Print "\ESC[6n" column witdh
putStr ("\ESC[" ++ show msv ++ "C") >>
putStr "\ESC[6n" >>
-- NOTE: Go back to saved position
putStr "\ESC8" >>
-- NOTE: 3) Print "\ESC[6n" current position after action
putStr "\ESC[6n" >> hFlush stdout >>
aux mlp hps hns (reverse k ++ bcs) acs
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 rp `isInfixOf` 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
-- NOTE: Relative paths instead of full
$ map (filter (/= '\NUL') . drop (length path))
$ 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 >>= \cs ->
length cs `seq` pure cs
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 }