A-gent-0.11.0.8: src/Internal/RIO.hs
{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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 Internal.RIO
( 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
-- * Internal
, findFiles
, readFileStrict
-- * Temp
, timestampUTC
)
where
--------------------------------------------------------------------------------
import Data.Either ( partitionEithers )
import Data.List ( isPrefixOf )
import Data.Maybe ( maybeToList )
import qualified System.Environment.Blank as ENV
import System.Exit
( ExitCode (ExitFailure, ExitSuccess)
)
import System.IO
( hClose
, hFlush
, hGetContents
, hPutStrLn
, hReady
, stdin
, stdout
)
import System.Process
( CreateProcess (cwd, std_err, std_in, std_out)
, StdStream (CreatePipe)
, createProcess
, proc
, readCreateProcessWithExitCode
, readProcessWithExitCode
, waitForProcess
)
import Text.Read ( readMaybe )
import qualified Internal.LLM as LLM
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:
-- "\^[[#;#R" => "\^[" 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
input prev next =
-- NOTE: "\^[7" - save cursor position (SCO)
-- - https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797#cursor-controls
RestrictedIO $ putStr "\^[7" >> aux gen prev next [] []
where
msv = 32767 :: Int
gen =
MultiLine
{ stx = Nothing
, cur = Nothing
, etx = Nothing
, col = 0
}
aux mlp hps hns bcs acs =
block >>= \ blk ->
case (blk < ['\32'], blk) of
-- NOTE: To view keystrokes, use: `ghc -e getLine` (hit + ENTER) and
-- then map to ASCII control codes (use Caret notation cos Λ prefix):
--
-- - https://en.wikipedia.org/wiki/ASCII#Control_code_table
(True , ['\^J']) -> caseEnter
(True , ['\^H']) -> caseBackspace
(True , ['\^[','[','3','~']) -> caseDelete
(True , ['\^D']) -> caseDelete
(True , ['\^[','[','H']) -> caseHome
(True , ['\^A']) -> caseHome
(True , ['\^[','[','F']) -> caseEnd
(True , ['\^E']) -> caseEnd
(True , ['\^L']) -> caseWipe
(True , ['\^U']) -> caseWipeStart
(True , ['\^K']) -> caseWipeEnd
(True , ['\^[','[','A']) -> caseArrowUp
(True , ['\^[','[','B']) -> caseArrowDown
(True , ['\^[','[','C']) -> caseArrowRight blk
(True , ['\^[','[','D']) -> caseArrowLeft blk
(True , ['\^[','[','1',';','5','C']) -> caseArrowCtrlRight
(True , ['\^[','[','1',';','5','D']) -> caseArrowCtrlLeft
(True , '\^[':ps) -> casePositions ps
(True , _) -> caseSkip
(False, ['\DEL']) -> caseSkip
(False, _) -> caseText blk
where
caseEnter =
-- NOTE: ENTER (line feed) only if something is typed
case (bcs, acs) of
([], []) ->
aux mlp hps hns bcs acs
________ ->
hFlush stdout >>
-- NOTE: Move to end of text
putStr hom >>
hFlush stdout >>
(pure . (++ acs) . reverse) bcs
where
hom =
case mlp of
MultiLine { etx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
[]
caseBackspace =
-- NOTE: BACKSPACE / CTRL + H (remove char if any and re-write
-- after chars)
case bcs of
[ ] -> aux mlp hps hns bcs acs
(_:cs) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Remove char
putChar '\^H' >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns cs acs
caseDelete =
-- NOTE: DELETE / CTRL + D behave as delete key
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 "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr cs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns bcs cs
caseHome =
-- NOTE: HOME / CTRL + A to move to start of text
hFlush stdout >>
putStr hom >>
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) }
, "\^[[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, "\^[8"
)
caseEnd =
-- NOTE: END / CTRL + E to move to end of text
hFlush stdout >>
putStr hom >>
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) }
, "\^[[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, []
)
caseWipe =
-- NOTE: CTRL + L (form feed) becomes "/w" (clear screen)
pure "/wipe"
caseWipeStart =
-- NOTE: CTRL + U cut text to start
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Go back to start of line
putStr hom >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns [] acs
where
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\^[8"
caseWipeEnd =
-- NOTE: CTRL + K cut text to end
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns bcs []
caseArrowUp =
-- NOTE: Allowed escaped sequences: Arrow "↑"
case (hps, hns) of
([ ], _) -> aux mlp hps hns bcs acs
(p:ps, _) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Print previous line
putStr p >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr [] >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp ps (p:hns) rev []
where
rev = reverse p
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\^[8"
caseArrowDown =
-- NOTE: Allowed escaped sequences: Arrow "↓"
case (hps, hns) of
(_, [ ]) -> aux mlp hps hns bcs acs
(_, p:ps) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Print previous line
putStr p >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr [] >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp (p:hps) ps rev []
where
rev = reverse p
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\^[8"
caseArrowRight str =
-- NOTE: Allowed escaped sequences: Arrow "→"
case (bcs, acs) of
(_, [ ]) ->
aux mlp hps hns bcs acs
(_, c:cs) ->
hFlush stdout >>
( if pl then
putStr ("\^[[" ++ "1" ++ "E")
else
putStr str
) >>
-- NOTE: Update current position
putStr "\^[[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
caseArrowLeft str =
-- NOTE: Allowed escaped sequences: Arrow "←"
case (bcs, acs) of
([ ], _) ->
aux mlp hps hns bcs acs
(c:cs, _) ->
hFlush stdout >>
( if pl then
putStr ("\^[[" ++ "1" ++ "F") >>
putStr ("\^[[" ++ show msv ++ "C")
else
putStr str
) >>
-- NOTE: Update current position
putStr "\^[[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
caseArrowCtrlRight =
-- NOTE: Allowed escaped sequences: CTRL + Arrow "→"
-- NOTE: Move to end of text
hFlush stdout >>
putStr np >>
-- NOTE: Update current position
putStr "\^[[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) ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy + 1
x = lc - (cw - cx)
__________ ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy
x = cx + lc
___ -> []
caseArrowCtrlLeft =
-- NOTE: Allowed escaped sequences: CTRL + Arrow "←"
hFlush stdout >>
putStr np >>
-- NOTE: Update current position
putStr "\^[[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) ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy - 1
x = cw - (lc - cx)
__________ ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy
x = cx - lc
___ -> []
casePositions ps =
-- NOTE: Other escaped sequences (skip unless positions)
aux mln hps hns bcs acs
where
ops = map readMaybe $ COM.split '\^[' ps :: [Maybe Position]
mln =
-- NOTE: 0) Print "\^[[6n" position before action (unused)
-- NOTE: 1) Print "\^[[6n" end position after action
-- NOTE: 2) Print "\^[[6n" column witdh
-- NOTE: 3) Print "\^[[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
caseSkip =
aux mlp hps hns bcs acs
caseText str =
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Type key or text
putStr str >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns (reverse str ++ bcs) acs
block =
-- NOTE: https://stackoverflow.com/a/38553473
--
-- We refactored and named it `block` instead of `key` as it is possible
-- to paste a huge block of text. Calling that a keystroke, doesn't seem
-- appropiate
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)
:: m (Maybe LLM.Root)
instance
EFF.LlmConf RIO
=> LlmConf RIO
where
-- llmPathCWD = getEnvVar "LLM_PATH_CWD"
llmPathCWD =
( \ case
Just rp -> Just $ LLM.Root rp
Nothing -> Nothing
)
<$> 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 LLM.Filter
-> m (Either [String] LLM.Files)
llmCodeGet
:: String
-> m (Either String LLM.File)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeRoot RIO
, EFF.LlmCodeMask RIO
)
=> LlmCodeRead RIO
where
llmCodeSeq mfilter =
EFF.llmPathCWD >>= \ ocwd ->
case ocwd of
Just (LLM.Root root) ->
EFF.llmCodeDir >>= \ cdir ->
EFF.llmCodeMsk >>= \ cmsk ->
realPath (root ++ "/" ++ cdir) >>= \ efap ->
case efap of
-- TODO: DRY
Right fap ->
( \ case
([], rs) -> Right $ LLM.Files $ concat rs
(ls, __) -> Left ls
)
. partitionEithers
<$> mapM (\ msk -> findFiles fap ("*" ++ fil ++ "*" ++ msk)) cmsk
Left err ->
pure $ Left [err]
Nothing ->
pure $ Left [noLlmConf]
where
fil =
case mfilter of
Just (LLM.Filter f) -> f
Nothing -> [ ]
llmCodeGet abspath =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmCodeDir >>= \ cdir ->
case ocwd of
-- TODO: DRY
Just (LLM.Root root) ->
realPath (root ++ "/" ++ cdir) >>= \ efap ->
case efap of
Right fap ->
if fap `isPrefixOf` abspath then
Right . LLM.File . (,) abspath . lines
<$> readFileStrict abspath
else
pure $ Left $ notPrefixRootAndMode fap abspath LLM.Code
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmPlanRoot m
where
llmPlanDir
:: m String
instance
( EFF.LlmConf RIO
, EFF.LlmPlanRoot RIO
)
=> LlmPlanRoot RIO
where
llmPlanDir = pure "."
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmPlanMask m
where
llmPlanMsk
:: m [String]
instance
( EFF.LlmConf RIO
, EFF.LlmPlanMask RIO
)
=> LlmPlanMask RIO
where
llmPlanMsk =
pure
[ "*.org"
, "*.md"
]
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmPlanRoot m
, EFF.LlmPlanMask m
, EFF.LlmCodeRead m
)
=> LlmPlanRead m
where
llmPlanSeq
:: Maybe LLM.Filter
-> m (Either [String] LLM.Files)
llmPlanGet
:: String
-> m (Either String LLM.File)
instance
( EFF.LlmConf RIO
, EFF.LlmPlanRoot RIO
, EFF.LlmPlanMask RIO
, EFF.LlmCodeRead RIO
)
=> LlmPlanRead RIO
where
llmPlanSeq mfilter =
EFF.llmPathCWD >>= \ ocwd ->
case ocwd of
Just (LLM.Root root) ->
EFF.llmPlanDir >>= \ pdir ->
EFF.llmPlanMsk >>= \ pmsk ->
realPath (root ++ "/" ++ pdir) >>= \ efap ->
case efap of
-- TODO: DRY
Right fap ->
( \ case
([], rs) -> Right $ LLM.Files $ concat rs
(ls, __) -> Left ls
)
. partitionEithers
<$> mapM (\ msk -> findFiles fap ("*" ++ fil ++ "*" ++ msk)) pmsk
Left err ->
pure $ Left [err]
Nothing ->
pure $ Left [noLlmConf]
where
fil =
case mfilter of
Just (LLM.Filter f) -> f
Nothing -> [ ]
llmPlanGet abspath =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmPlanDir >>= \ pdir ->
case ocwd of
-- TODO: DRY
Just (LLM.Root root) ->
realPath (root ++ "/" ++ pdir) >>= \ efap ->
case efap of
Right fap ->
if fap `isPrefixOf` abspath then
Right . LLM.File . (,) abspath . lines
<$> readFileStrict abspath
else
pure $ Left $ notPrefixRootAndMode fap abspath LLM.Plan
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
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 ->
case ocwd of
Just (LLM.Root root) ->
realPath root >>= \ efap ->
case efap of
Right rp ->
gitExist rp >>= \ git ->
gitignoreTmp rp >>= \ tmp ->
case (git, tmp) of
(True, True) ->
EFF.llmPlanAPI >>= \ mapi ->
EFF.llmPlanKey >>= \ mkey ->
llmCurl json mapi mkey
(False, ____) ->
pure $ Left "No GIT repo initialized"
(____, False) ->
pure $ Left "No /tmp/ folder added to the .gitignore file"
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- HELPERS (public)
findFiles
:: FilePath
-> 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: We use absolute paths, but, only show relative
$ map (filter (/= '\NUL'))
$ lines str
Left err ->
Left err
)
<$> withExitCodeCwd path "find"
[ path
, "-path"
, mask
]
getEnvVar
:: String
-> RIO (Maybe String)
getEnvVar =
RestrictedIO . ENV.getEnv
--------------------------------------------------------------------------------
-- HELPERS (private)
noLlmConf :: String
noLlmConf =
"No EFF.LlmConf instance is defined."
notPrefixRootAndMode
:: FilePath
-> FilePath
-> LLM.Mode
-> String
notPrefixRootAndMode rpath apath mode =
rpath ++ " is not a prefix of " ++ apath ++ " for: " ++ show mode
gitExist
:: FilePath
-> RIO Bool
gitExist path =
( \case
Right _ -> True
Left _ -> False
)
<$> withExitCodeCwd path "git"
[ "status"
]
gitignoreTmp
:: FilePath
-> RIO Bool
gitignoreTmp path =
any (== "/tmp/") . lines
<$> readFileStrict gi
where
gi = path ++ "/.gitignore"
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) ->
withExitCodeStdIn "curl"
( [ --"--verbose"
"--silent"
, "--show-error"
]
++ hs ++
[ -- NOTE: https://curl.se/docs/manpage.html#--json
"--json", "@-"
, api ++ "/chat/completions"
]
)
json
(Just api, Just key) ->
withExitCodeStdIn "curl"
( [ --"--verbose"
"--silent"
, "--show-error"
, "--header", "\"Authorization: \"" ++ key ++ "\""
]
++ hs ++
[ -- NOTE: https://curl.se/docs/manpage.html#--json
"--json", "@-"
, api ++ "/chat/completions"
]
)
json
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
:: FilePath
-> 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
]
timestampUTC :: RIO (Maybe String)
timestampUTC =
( \case
Right str -> Just str
Left ___ -> Nothing
)
<$> withExitCode "date"
[ "-u"
, "+'%Y%m%d-%H%M%S-%N'"
]
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
withExitCodeStdIn
:: String
-> [String]
-> String
-> RIO (Either String String)
withExitCodeStdIn cmd args txt =
RestrictedIO $
do
(Just hinp, Just hout, Just herr, ph) <- createProcess rcp
hPutStrLn hinp txt
hClose hinp
out <- hGetContents hout
err <- hGetContents herr
exitcode <- waitForProcess ph
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
where
raw = proc cmd args
rcp =
raw
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
withExitCodeCwd
:: String
-> String
-> [String]
-> RIO (Either String String)
withExitCodeCwd 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 }