Restricted.hs

{-# OPTIONS_GHC -Wall -Werror #-}

{-# LANGUAGE Safe                         #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}

{-# LANGUAGE FlexibleContexts             #-}
{-# LANGUAGE UndecidableInstances         #-}

{-# LANGUAGE LambdaCase                   #-}

{-# LANGUAGE MonoLocalBinds               #-}

--------------------------------------------------------------------------------

-- |
-- Copyright  : (c) 2026 SPISE MISU ApS
-- License    : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability  : experimental
--
-- Safe {H}askell
--
-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html
--
-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12:
-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen,
-- Denmark, ACM, 2012
--
-- Though Haskell is predominantly type-safe, implementations contain a few
-- loopholes through which code can bypass typing and module encapsulation. This
-- paper presents Safe Haskell, a language extension that closes these
-- loopholes. Safe Haskell makes it possible to confine and safely execute
-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell
-- allows a variety of different policies from API sandboxing to
-- information-flow control to be implemented easily as monads. Safe Haskell is
-- aimed to be as unobtrusive as possible. It enforces properties that
-- programmers tend to meet already by convention. We describe the design of
-- Safe Haskell and an implementation (currently shipping with GHC) that infers
-- safety for code that lies in a safe subset of the language. We use Safe
-- Haskell to implement an online Haskell interpreter that can securely execute
-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly
-- simplifies this task and allows the use of a large body of existing code and
-- tools.

--------------------------------------------------------------------------------

module Agent.IO.Restricted
  ( RIO ()
  , run
    -- * Environment
  , getEnvVar
    -- * Read/Print
  , input
  , output
    -- * LLM (Chat)
  , llmChatKey, llmChatAPI
  , llmChatCurl
    -- * LLM (Code)
  )
where

--------------------------------------------------------------------------------

import qualified System.Environment.Blank as ENV
import           System.IO
  {-
  ( hFlush, hPutStr, stdout
  , hSetEncoding
  , utf8
  )
  -}
  ( hFlush, stdout
  )
import           System.Exit
  ( ExitCode
    ( ExitFailure
    , ExitSuccess
    )
  )
import           System.Process
  ( readProcessWithExitCode
  )

import qualified Agent.IO.Effects as EFF

--------------------------------------------------------------------------------

newtype RIO a = RestrictedIO { run :: IO a }

instance Functor RIO where
  fmap f m = RestrictedIO $      f <$> run m

instance Applicative RIO where
  pure      = RestrictedIO . pure
  (<*>) f m = RestrictedIO $ run f <*> run m

instance Monad RIO where
  (>>=) m f = RestrictedIO $ run m >>= run . f

--------------------------------------------------------------------------------

class StdIn m where
  input :: m String 

class StdOut m where
  output :: String -> m ()

instance StdIn RIO where
  input = RestrictedIO getLine

instance StdOut RIO where
  output x = RestrictedIO $
    {- BUG: Emojis can't be printed to console (UTF-16 "surrogate pairs")
       <stdout>: hPutChar: invalid argument (cannot encode character '\55357'
    hSetEncoding stdout utf8 >>
    hPutStr      stdout x >>
    hFlush       stdout
    -}
    putStr x >> hFlush stdout

--------------------------------------------------------------------------------

class SysEnv m where
  getEnvVar :: String -> m (Maybe String)

instance SysEnv RIO where
  getEnvVar = RestrictedIO . ENV.getEnv

--------------------------------------------------------------------------------

class ReadProc m where
  withExitCode :: String -> [String] -> m (Either String String)

instance ReadProc RIO where
  withExitCode app fs = RestrictedIO $
    do
      (exitcode, out, err) <- readProcessWithExitCode app fs []
      case exitcode of
        ExitSuccess ->
          return $ Right out
        ExitFailure _ ->
          return $ Left err

--------------------------------------------------------------------------------

class (EFF.LlmChatConf m, SysEnv m) => LlmChatConf m where
  llmChatAPI :: m (Maybe String)
  llmChatKey :: m (Maybe String)

instance (EFF.LlmChatConf RIO, SysEnv RIO) => LlmChatConf RIO where
  llmChatAPI = getEnvVar "LLM_CHAT_LOCALHOST_API"
  llmChatKey = pure Nothing

class (EFF.LlmChatConf m , ReadProc m) => LlmChatCurl m where
  llmChatCurl :: String -> m (Either String String)

instance (EFF.LlmChatConf RIO, ReadProc RIO) => LlmChatCurl RIO where
  llmChatCurl json =
    llmChatAPI >>= \ mapi ->
    llmChatKey >>= \ mkey ->
    case (mapi, mkey) of
      (Nothing, _ ) ->
        RestrictedIO $ pure $ Left "No API address was provided"
      (Just api, Nothing) ->
        ( \ case
              Right env -> Right env
              Left  err -> Left  err
        )
        <$> withExitCode "curl"
            [ "--silent"
            , "--show-error"
            , "--header" , "\"Content-Type: application/json; charset=utf-8\""
            , "--data"   , json
            , api ++ "/chat/completions"
            ]
      (Just api, Just key) ->
        ( \ case
              Right env -> Right env
              Left  err -> Left  err
        )
        <$> withExitCode "curl" -- "echo" -- 
            [ "--silent"
            , "--show-error"
            , "--header" , "\"Authorization: \"" ++ key ++ "\" "
            , "--header" , "\"Content-Type: application/json; charset=utf-8\""
            , "--data"   , json
            , api ++ "/chat/completions"
            ]