A-gent-0.11.0.19: 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
-- * Timestamps
, timestampUTC
-- * MultiThreading
, fork
, wait
, join
, tmax
, ttid
, tkil
, tnum
, tvar
, tval
, terr
-- * LLM (Config)
, llmPathCWD
-- * LLM (Chat)
, llmChatKey, llmChatAPI
, llmChatWeb
-- * LLM (Code)
, llmCodeDir
, llmCodeMsk
, llmCodeIns, llmCodeExa
, llmCodeSeq, llmCodeGet, llmCodeGit
, llmCodePut
, llmCodeKey, llmCodeAPI
, llmCodeWeb
-- * LLM (Plan)
, llmPlanDir
, llmPlanMsk
, llmPlanSeq, llmPlanGet
, llmPlanKey, llmPlanAPI
, llmPlanWeb
)
where
--------------------------------------------------------------------------------
import Prelude hiding ( mod )
import Control.Concurrent ( ThreadId )
import Control.Exception ( SomeException, try )
import Data.Char ( isDigit )
import Data.Either ( fromLeft, 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 Internal.Utils as UTL
import qualified Agent.IO.Effects as EFF
import Agent.Control.Concurrent ( Task )
import qualified Agent.Control.Concurrent as CON
--------------------------------------------------------------------------------
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 MultiThreading m where
fork :: m a -> m (Task a)
wait :: Task a -> m a
join :: [ Task a ] -> m ( )
--
tmax :: m Int
ttid :: Task a -> m ThreadId
tkil :: Task a -> m String
tnum :: Task a -> m String
tvar :: Task a -> m Bool
tval :: Task a -> m (Maybe a)
terr :: Task a -> m (Maybe String)
--------------------------------------------------------------------------------
instance MultiThreading RIO where
fork (RestrictedIO io) = RestrictedIO $ CON.fork io
wait = RestrictedIO . CON.wait
join = RestrictedIO . CON.join
--
tmax = RestrictedIO $ CON.tmax
ttid = pure . CON.ttid
tkil = RestrictedIO . CON.tkil
tnum = pure . CON.tnum
tvar = RestrictedIO . CON.tvar
tval = RestrictedIO . CON.tval
terr = RestrictedIO . CON.terr
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
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 $ UTL.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 LLM.Root)
instance
EFF.LlmConf RIO
=> LlmConf RIO
where
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.LlmCodeTmpl m
=> LlmCodeTmpl m
where
llmCodeIns
:: m [LLM.File]
llmCodeExa
:: m [LLM.File]
instance
( EFF.LlmConf RIO
, EFF.LlmCodeTmpl RIO
)
=> LlmCodeTmpl RIO
where
llmCodeIns =
EFF.llmPathCWD >>= \ ocwd ->
case ocwd of
Just (LLM.Root root) ->
realPath (root ++ "llm") >>= \ efap ->
case efap of
-- TODO: DRY
Right fap ->
findFiles fap "*code_instructions_*.json" >>= \ eafps ->
case eafps of
Right afps ->
mapM
( \ abspath ->
LLM.File . (,) abspath . lines
<$> readFileStrict abspath
) afps
Left __ ->
pure []
Left ____ ->
pure []
Nothing ->
pure []
llmCodeExa =
EFF.llmPathCWD >>= \ ocwd ->
case ocwd of
Just (LLM.Root root) ->
realPath (root ++ "llm") >>= \ efap ->
case efap of
-- TODO: DRY
Right fap ->
findFiles fap "*code_examples_*.md" >>= \ eafps ->
case eafps of
Right afps ->
mapM
( \ abspath ->
LLM.File . (,) abspath . lines
<$> readFileStrict abspath
) afps
Left __ ->
pure []
Left ____ ->
pure []
Nothing ->
pure []
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeRoot m
, EFF.LlmCodeMask m
)
=> LlmCodeRead m
where
llmCodeSeq
:: Maybe LLM.Filter
-> m (Either [String] LLM.FilePaths)
llmCodeGet
:: LLM.AbsoluteFilePath
-> m (Either String LLM.File)
llmCodeGit
:: m (Either String String)
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.FilePaths $ mconcat 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 (LLM.AbsoluteFilePath 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
-- NOTE: Root relative path
Right . LLM.File . (,) (drop len abspath) . lines
<$> readFileStrict abspath
else
pure $ Left $ notPrefixRootAndMode fap abspath LLM.Code
Left err ->
pure $ Left err
where
len = length root
Nothing ->
pure $ Left noLlmConf
llmCodeGit =
EFF.llmPathCWD >>= \ ocwd ->
case ocwd of
Just (LLM.Root root) ->
realPath root >>= \ efap ->
case efap of
-- TODO: DRY
Right fap ->
gitExist fap >>= \ igit ->
if igit then
gitBranchesDesc fap
else
pure $ Left "No GIT repo initialized"
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeRoot m
)
=> LlmCodeSave m
where
llmCodePut
:: String
-> LLM.Files
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeRoot RIO
)
=> LlmCodeSave RIO
where
-- TODO: Needs some refactoring at some point …
llmCodePut ___ (LLM.Files []) =
pure $ Left "No files provided, therefore no action performed"
llmCodePut txt (LLM.Files fs) =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmCodeDir >>= \ cdir ->
case ocwd of
Just (LLM.Root root) ->
realPath root >>= \ erap ->
case erap of
Right rp ->
gitExist rp >>= \ igit ->
gitignoreTmp rp >>= \ itmp ->
case (igit, itmp) of
(True, True) ->
timestampUTC >>= \ mts ->
case mts of
Just ts ->
realPath (root ++ "tmp") >>= \ etmp ->
case etmp of
Right tmp ->
gitWorktreeAdd root ts tap >>= \ ewta ->
(
mapM
( \ (LLM.File (fp, fls)) ->
let
fil = tap ++ "/" ++ fp
len = length $ tap ++ "/"
in
if dir `isPrefixOf` fil then
ensureFolderPath tap fil >>= \ eefp ->
writeFileStrict fil (unlines fls) >>= \ ewfs ->
case (eefp, ewfs) of
(Right efp, Right wfs) ->
pure $ Right $ unlines
[ "* Ensuring folder exists:"
, efp
, "* Writing file to folder:"
, wfs
]
(_, _) ->
pure $ Left $ unlines
[ "* Ensuring folder exists:"
, fromLeft "No error" eefp
, "* Writing file to folder:"
, fromLeft "No error" ewfs
]
else
pure $ Left $
( (drop len fil) ++
" doesn't start with " ++
(drop len dir)
)
)
fs
) >>= \ ewfs ->
gitAddFiles tap >>= \ ewaf ->
gitCommit tap txt >>= \ ewcf ->
gitWorktreeRem root tap >>= \ ewrf ->
case
( ewta
, partitionEithers ewfs
, ewaf
, ewcf
, ewrf
)
of
( Right wta
, ( []
, xs
)
, Right ___
, Right wcf
, Right wrf
) ->
gitUpdateBranchDesc root ts mod >>= \ ewtb ->
case ewtb of
Right _ ->
pure $ Right $ unlines
[ "# Temporary worktree branch:"
, "## Adding:"
, wta
, "## Saving files:"
, concat xs
, "## Adding files and committing :"
, wcf
, "## Removing:"
, wrf
]
Left e -> pure $ Left e
where
mod = "[CODE] " ++ txt
( _, (es,__), _, _, _) ->
gitUpdateBranchDesc root ts err >>= \ ewtb ->
case ewtb of
Right _ ->
pure $ Left $ unlines
[ "# Temporary worktree branch error(s):"
, "## Adding:"
, fromLeft "No error" ewta
, "## Adding description:"
, fromLeft "No error" ewtb
, "## Saving files:"
, concat $ map (++ "\n") es
, "## Adding files:"
, fromLeft "No error" ewaf
, "## Committing:"
, fromLeft "No error" ewcf
, "## Removing:"
, fromLeft "No error" ewrf
]
Left e -> pure $ Left e
where
err = "[FAIL] " ++ txt
where
tap = tmp ++ "/" ++ ts
dir = tap ++ "/" ++ cdir
Left e ->
pure $ Left e
_______ ->
pure $ Left "No timestamp"
(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
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeConf m
)
=> LlmCodeConf m
where
llmCodeAPI
:: m (Maybe String)
llmCodeKey
:: m (Maybe String)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeConf RIO
)
=> LlmCodeConf RIO
where
llmCodeAPI = getEnvVar "LLM_CODE_LOCALHOST_API"
llmCodeKey = pure Nothing
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeConf m
)
=> LlmCodePost m
where
llmCodeWeb
:: String
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeConf RIO
)
=> LlmCodePost RIO
where
llmCodeWeb json =
EFF.llmCodeAPI >>= \ mapi ->
EFF.llmCodeKey >>= \ mkey ->
llmCurl json mapi mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
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.FilePaths)
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.FilePaths $ mconcat 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
-- NOTE: Root relative path
Right . LLM.File . (,) (drop len abspath) . lines
<$> readFileStrict abspath
else
pure $ Left $ notPrefixRootAndMode fap abspath LLM.Plan
Left err ->
pure $ Left err
where
len = length root
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.llmPlanAPI >>= \ mapi ->
EFF.llmPlanKey >>= \ mkey ->
llmCurl json mapi mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- HELPERS (public)
getEnvVar
:: String
-> RIO (Maybe String)
getEnvVar =
RestrictedIO . ENV.getEnv
--------------------------------------------------------------------------------
-- HELPERS (private)
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"
-- NOTE: Use -ipath and -iname (case insensitive) instead?
[ path
-- NOTE: Limit to files, excluding symbolic links
, "-type", "f"
-- NOTE: Exclude tmp folder
, "-not"
, "-path"
, path ++ "/tmp/*"
, "-and"
-- NOTE: Exclude llm tpl folder
, "-not"
, "-ipath"
, path ++ "/llm/*"
, "-and"
-- NOTE: Exclude dot files and hereby tmp Emacs files (.*#)
, "-not"
, "-name"
, ".*"
, "-and"
-- NOTE: Look for filter mask
, "-path"
, mask
, "-print"
]
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"
gitWorktreeAdd
:: FilePath
-> String
-> FilePath
-> RIO (Either String String)
gitWorktreeAdd root ts path =
withExitCodeCwd root "git"
[ "worktree"
, "add", "-b", ts
, path
]
gitAddFiles
:: FilePath
-> RIO (Either String String)
gitAddFiles path =
withExitCodeCwd path "git"
[ "add"
, "."
]
gitCommit
:: FilePath
-> String
-> RIO (Either String String)
gitCommit root mesg =
withExitCodeCwd root "git"
[ "commit"
, "-m"
, mesg
]
gitWorktreeRem
:: FilePath
-> FilePath
-> RIO (Either String String)
gitWorktreeRem root path =
withExitCodeCwd root "git"
[ "worktree"
, "remove"
, path
]
gitBranchesDesc
:: FilePath
-> RIO (Either String String)
gitBranchesDesc root =
withExitCodeCwd root "git"
[ "config"
, "--get-regexp"
, "branch.*.description"
]
gitUpdateBranchDesc
:: FilePath
-> String
-> String
-> RIO (Either String String)
gitUpdateBranchDesc path ts desc =
withExitCodeCwd path "git"
[ "config"
, "branch." ++ ts ++ ".description"
, desc
]
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 =
-- TODO:
--
-- Refactor `RIO String` to `RIO (Either String String)`
RestrictedIO $
do
eproc <-
try
( aux
) :: IO (Either SomeException String)
case eproc of
Right txt -> pure txt
Left ___ -> pure []
where
aux =
readFile path >>= \cs ->
length cs `seq` pure cs
writeFileStrict
:: FilePath
-> String
-> RIO (Either String String)
writeFileStrict path txt =
RestrictedIO $
do
eproc <-
try
( writeFile path txt
) :: IO (Either SomeException ())
case eproc of
Right _ ->
pure $ Right path
Left e -> pure $ Left $ show e
realPath
:: FilePath
-> RIO (Either String String)
realPath path =
-- NOTE: `realpath` removes any trailing '/' for directories
--
-- NOTE: Remove any '\NUL` from filepaths
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110
( \case
Right str -> Right $ filter (/= '\n') str
Left err -> Left err
)
<$> withExitCode "realpath"
[ path
]
ensureFolderPath
:: FilePath
-> FilePath
-> RIO (Either String String)
ensureFolderPath root path =
withExitCodeCwd root "dirname" [ path ] >>= \ eadp ->
case eadp of
Right adp ->
withExitCodeCwd root "mkdir" [ "-p", foo ] >>= \ emeh ->
case emeh of
Right _ -> pure $ Right foo
Left e -> pure $ Left e
where
foo = filter (/= '\n') adp
Left err -> pure $ Left err
timestampUTC :: RIO (Maybe String)
timestampUTC =
( \case
Right cs -> Just $ filter ( \ c -> c == '-' || isDigit c ) cs
Left __ -> Nothing
)
<$> withExitCode "date"
[ "-u"
, "+'%Y%m%d-%H%M%S-%N'"
]
withExitCode
:: String
-> [String]
-> RIO (Either String String)
withExitCode cmd args =
RestrictedIO $
do
eproc <-
try
( readProcessWithExitCode cmd args []
) :: IO (Either SomeException ((ExitCode, String, String)))
case eproc of
Right (exitcode, out, err) ->
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left $ err
Left e -> pure $ Left $ show e
withExitCodeStdIn
:: String
-> [String]
-> String
-> RIO (Either String String)
withExitCodeStdIn cmd args txt =
RestrictedIO $
do
eproc <-
try
( aux
) :: IO (Either SomeException ((ExitCode, String, String)))
case eproc of
Right (exitcode, out, err) ->
case exitcode of
ExitSuccess ->
-- NOTE: When debugging, ex: `curl`, add the `--verbose` flag,
-- which uses `stderr`. Just combine `err` and `out` like this:
--
-- pure $ Right ("[DEBUG]: " ++ err ++ "\n" ++ out)
pure $ Right out
ExitFailure _ ->
pure $ Left $ err
Left e -> pure $ Left $ show e
where
raw = proc cmd args
rcp =
raw
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
aux =
do
(Just hinp, Just hout, Just herr, ph) <- createProcess rcp
hPutStrLn hinp txt
hClose hinp
out <- hGetContents hout
err <- hGetContents herr
exitcode <- waitForProcess ph
return (exitcode, out, err)
withExitCodeCwd
:: String
-> String
-> [String]
-> RIO (Either String String)
withExitCodeCwd path cmd args =
RestrictedIO $
do
eproc <-
try
( readCreateProcessWithExitCode rcp []
) :: IO (Either SomeException ((ExitCode, String, String)))
case eproc of
Right (exitcode, out, err) ->
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left $ err
Left e -> pure $ Left $ show e
where
raw = proc cmd args
rcp = raw { cwd = Just path }