aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore3
-rw-r--r--README.md9
-rwxr-xr-xbwrap-files/chroot-initialise.sh4
-rwxr-xr-xbwrap-files/entry.sh6
-rwxr-xr-xbwrap-files/make-chroot.sh31
-rwxr-xr-xbwrap-files/start.sh45
-rw-r--r--cabal.project7
-rw-r--r--src/ExitEarly.hs40
-rw-r--r--src/Ghci.hs172
-rw-r--r--src/IRC.hs62
-rw-r--r--src/Main.hs41
-rw-r--r--yahb2.cabal30
12 files changed, 450 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..4600c8f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+dist-newstyle/
+bwrap-files/ubuntu-base/
+irc-password.txt
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..56d185d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,9 @@
+# yahb2
+
+Dumb minimal reimagining of `yahb` operated by `mniip` in `#haskell` on
+libera.chat: ghci in your IRC channel. Too much stuff is hardcoded currently.
+
+Run `bwrap-files/make-chroot.sh` to initialise the chroot that ghci is started
+in. Make sure that you have a working `ghcup` installation on the host with a
+GHC installed; the started container just uses the `ghci` from the host `ghcup`
+installation.
diff --git a/bwrap-files/chroot-initialise.sh b/bwrap-files/chroot-initialise.sh
new file mode 100755
index 0000000..972bf75
--- /dev/null
+++ b/bwrap-files/chroot-initialise.sh
@@ -0,0 +1,4 @@
+#!/bin/bash
+sed -i '/^_apt:/d' /etc/passwd # See https://github.com/containers/bubblewrap/issues/210
+apt update && apt install -y build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 locales
+PATH="$PATH:/usr/sbin" dpkg-reconfigure locales
diff --git a/bwrap-files/entry.sh b/bwrap-files/entry.sh
new file mode 100755
index 0000000..f9c4ad3
--- /dev/null
+++ b/bwrap-files/entry.sh
@@ -0,0 +1,6 @@
+#!/bin/bash
+set -euo pipefail
+
+cd "$(dirname "$0")"
+
+ghcup --offline run -- ghci 2>&1
diff --git a/bwrap-files/make-chroot.sh b/bwrap-files/make-chroot.sh
new file mode 100755
index 0000000..d29d1af
--- /dev/null
+++ b/bwrap-files/make-chroot.sh
@@ -0,0 +1,31 @@
+#!/usr/bin/env bash
+set -euo pipefail
+
+cd "$(dirname "$0")"
+
+basedir=ubuntu-base
+
+[[ ($# -le 0 || "$1" != "-f") && -d "$basedir" ]] && {
+ echo >&2 "Warning: base directory already exists, use -f to force"
+ exit 1
+}
+
+mkdir -p "$basedir"
+curl -L 'http://cdimage.ubuntu.com/ubuntu-base/releases/20.04/release/ubuntu-base-20.04.1-base-amd64.tar.gz' | tar -C "$basedir" -xz
+
+args=(
+ --bind ubuntu-base /
+ --ro-bind /etc/resolv.conf /etc/resolv.conf
+ --tmpfs /tmp
+ --dev /dev
+ --proc /proc
+ --new-session
+ --unshare-all
+ --share-net
+ --die-with-parent
+ --gid 0 --uid 0
+ --chdir /
+ --ro-bind chroot-initialise.sh /tmp/chinit.sh
+ /bin/bash /tmp/chinit.sh
+)
+bwrap "${args[@]}"
diff --git a/bwrap-files/start.sh b/bwrap-files/start.sh
new file mode 100755
index 0000000..859145c
--- /dev/null
+++ b/bwrap-files/start.sh
@@ -0,0 +1,45 @@
+#!/bin/bash
+set -euo pipefail
+
+filesdir="$(dirname "$0")"
+cd "$filesdir"
+
+ghcup_base=$(ghcup whereis basedir)
+
+chroot="${filesdir}/ubuntu-base"
+
+args=(
+ --tmpfs /tmp
+ --ro-bind "${chroot}/bin" /bin
+ --ro-bind "${chroot}/usr/bin" /usr/bin
+ --ro-bind "${chroot}/usr/lib" /usr/lib
+ --ro-bind "${chroot}/usr/include" /usr/include
+ --ro-bind "${chroot}/lib" /lib
+ --ro-bind "${chroot}/lib64" /lib64
+ --dir "${ghcup_base}"
+ --ro-bind "${ghcup_base}/bin" "${ghcup_base}/bin"
+ --ro-bind "${ghcup_base}/ghc" "${ghcup_base}/ghc"
+ --ro-bind "${ghcup_base}/cache" "${ghcup_base}/cache"
+ --setenv PATH "/bin:/usr/bin:${ghcup_base}/bin"
+ --setenv GHCUP_INSTALL_BASE_PREFIX "$(dirname ${ghcup_base})"
+ --proc /proc
+ --chdir "/tmp"
+ --new-session
+ --unshare-all
+ --die-with-parent
+ --file 4 "/tmp/entry.sh"
+ /bin/bash "/tmp/entry.sh"
+)
+
+# Turn off core files
+ulimit -c 0
+
+# Limit on the number of processes
+ulimit -u 10000
+
+# Limit memory to 600 MiB. Note that the compiled program gets a 500 MiB memory
+# limit via the GHC RTS, so this limit is 1. to constrain GHC itself (including
+# any TH code), and 2. as a second-layer defense.
+ulimit -d $(( 600 * 1024 ))
+
+exec bwrap "${args[@]}" 4<"${filesdir}/entry.sh"
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000..23c8721
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,7 @@
+packages: .
+
+allow-newer:
+ irc-client:bytestring,
+ irc-client:text,
+ irc-conduit:bytestring,
+ irc-conduit:text
diff --git a/src/ExitEarly.hs b/src/ExitEarly.hs
new file mode 100644
index 0000000..2375093
--- /dev/null
+++ b/src/ExitEarly.hs
@@ -0,0 +1,40 @@
+module ExitEarly (
+ ExitEarlyT,
+ exitEarly,
+ execExitEarlyT,
+ okOrExitEarly,
+ lift,
+) where
+
+import Control.Monad (ap)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+
+
+newtype ExitEarlyT r m a = ExitEarlyT { runExitEarlyT :: (a -> m r) -> m r }
+
+instance Functor m => Functor (ExitEarlyT r m) where
+ fmap f (ExitEarlyT g) = ExitEarlyT (\k -> g (k . f))
+
+instance Monad m => Applicative (ExitEarlyT r m) where
+ pure x = ExitEarlyT ($ x)
+ (<*>) = ap
+
+instance Monad m => Monad (ExitEarlyT r m) where
+ ExitEarlyT g >>= f = ExitEarlyT (\k -> g (($ k) . runExitEarlyT . f))
+
+instance MonadTrans (ExitEarlyT r) where
+ lift act = ExitEarlyT (act >>=)
+
+instance MonadIO m => MonadIO (ExitEarlyT r m) where
+ liftIO act = ExitEarlyT (liftIO act >>=)
+
+exitEarly :: Monad m => r -> ExitEarlyT r m a
+exitEarly r = ExitEarlyT (\_ -> return r)
+
+okOrExitEarly :: Monad m => Either e a -> (e -> ExitEarlyT r m r) -> ExitEarlyT r m a
+okOrExitEarly (Left err) f = f err >>= exitEarly
+okOrExitEarly (Right x) _ = return x
+
+execExitEarlyT :: Monad m => ExitEarlyT r m r -> m r
+execExitEarlyT (ExitEarlyT g) = g return
diff --git a/src/Ghci.hs b/src/Ghci.hs
new file mode 100644
index 0000000..fbbaa65
--- /dev/null
+++ b/src/Ghci.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+module Ghci (
+ Ghci,
+ Result(..),
+ makeGhci,
+ runStmt,
+ runStmtClever,
+ terminateGhci,
+) where
+
+import Control.Exception (catch, SomeException)
+import Control.Monad (replicateM, when)
+import Data.Bifunctor (first)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.UTF8 as UTF8
+import qualified Data.ByteString.Lazy.UTF8 as LUTF8
+import Data.ByteString.Short (ShortByteString)
+import qualified Data.ByteString.Short as BSS
+import Data.Char (isSpace, toLower)
+import Data.List (nub)
+import Foreign
+import System.IO
+import System.Process
+import System.Random hiding (next)
+
+import ExitEarly
+
+
+data Ghci = Ghci
+ { ghciProc :: ProcessHandle
+ , ghciStdin :: Handle
+ , ghciStdout :: Handle
+ }
+
+data Result a = Error String | Ignored | Return a
+ deriving (Show)
+
+makeGhci :: IO Ghci
+makeGhci = do
+ (pipeOut, pipeIn) <- createPipe
+ (Just stdinH, _, _, proch) <- createProcess
+ (proc "./start.sh" [])
+ { cwd = Just "bwrap-files"
+ , std_in = CreatePipe
+ , std_out = UseHandle pipeIn
+ , std_err = UseHandle pipeIn }
+ return Ghci { ghciProc = proch
+ , ghciStdin = stdinH
+ , ghciStdout = pipeOut }
+
+runStmtClever :: Ghci -> String -> IO (Ghci, Result String)
+runStmtClever ghci line =
+ case dropWhile isSpace line of
+ ':' : line1 -> case words (map toLower (dropWhile isSpace line1)) of
+ ('!':_) : _ -> return (ghci, Ignored)
+ cmd : "prompt" : _
+ | "set" `startsWith` cmd -> return (ghci, Ignored)
+ cmd : _
+ | "def" `startsWith` cmd -> return (ghci, Ignored)
+ | "quit" `startsWith` cmd -> do
+ terminateGhci ghci
+ ghci' <- makeGhci
+ return (ghci', Return "")
+ _ -> runStmt ghci line
+ _ -> runStmt ghci line
+ where
+ startsWith :: String -> String -> Bool
+ long `startsWith` short = take (length short) long == short
+
+runStmt :: Ghci -> String -> IO (Ghci, Result String)
+runStmt ghci line = restarting 1 (\g -> runStmt' g line) ghci
+
+restarting :: Int -> (Ghci -> IO a) -> Ghci -> IO (Ghci, Result a)
+restarting numExcRestarts f ghci = do
+ closed <- hIsClosed (ghciStdin ghci)
+ ghci' <- if closed
+ then do
+ terminateGhci ghci
+ makeGhci
+ else return ghci
+ (f ghci' >>= \x -> return (ghci', Return x))
+ `catch` (\e -> do let _ = e :: SomeException
+ terminateGhci ghci'
+ ghci'' <- makeGhci
+ if numExcRestarts >= 1
+ then restarting (numExcRestarts - 1) f ghci''
+ else return (ghci'', Error "Oops, something went wrong"))
+
+terminateGhci :: Ghci -> IO ()
+terminateGhci ghci = terminateProcess (ghciProc ghci)
+
+runStmt' :: Ghci -> String -> IO String
+runStmt' ghci stmt = do
+ tag <- updatePrompt ghci
+ hPutStrLn (ghciStdin ghci) stmt
+ hFlush (ghciStdin ghci)
+ (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag
+ case reason of
+ ReachedMaxLen -> do
+ terminateGhci ghci -- because we lost the new prompt
+ return (formatOutput output) -- don't need to strip tag because 200 << 8192
+ ReachedTag -> return (formatOutput $ take (length output - length tag) output)
+ ReachedEOF -> do
+ terminateGhci ghci
+ return (formatOutput output)
+ where
+ formatOutput (replaceNewlines . dropBothSlow isSpace -> output)
+ | length output > 200 = take 197 output ++ "..."
+ | otherwise = output
+ dropBothSlow f = reverse . dropWhile f . reverse . dropWhile f
+ replaceNewlines = map (\case '\n' -> ' ' ; c -> c)
+
+-- | Returns new prompt tag
+updatePrompt :: Ghci -> IO String
+updatePrompt ghci = do
+ tag <- genTag
+ -- putStrLn ("chose prompt: " ++ tag)
+ hPutStrLn (ghciStdin ghci) (":set prompt " ++ tag)
+ hFlush (ghciStdin ghci)
+ -- putStrLn ("set prompt " ++ tag)
+ _ <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag
+ return tag
+
+genTag :: IO String
+genTag = replicateM 20 (getStdRandom (uniformR ('a', 'z')))
+
+data CutoffReason = ReachedMaxLen | ReachedTag | ReachedEOF
+ deriving (Show)
+
+hGetUntilUTF8 :: Handle -> Maybe Int -> String -> IO (String, CutoffReason)
+hGetUntilUTF8 h mmax tag =
+ first LUTF8.toString <$> hGetUntil h mmax (BSS.toShort (UTF8.fromString tag))
+
+hGetUntil :: Handle -> Maybe Int -> ShortByteString -> IO (Lazy.ByteString, CutoffReason)
+hGetUntil h mmax tag = do
+ let size = 1024
+ exceedsMax yet = case mmax of Just m -> yet >= m
+ Nothing -> True
+ -- putStrLn ("tag = " ++ show tag)
+ allocaBytes size $ \ptr -> do
+ let loop yet havePrefixes builder = do
+ when (exceedsMax yet) $ exitEarly (BSB.toLazyByteString builder, ReachedMaxLen)
+
+ nread <- lift $ hGetBufSome h ptr size
+ when (nread <= 0) $ exitEarly (BSB.toLazyByteString builder, ReachedEOF)
+
+ bs <- lift $ BS.packCStringLen (ptr, nread)
+ -- lift $ putStrLn ("Read: " ++ show bs)
+ when (or [BSS.toShort (BS.takeEnd suflen bs) == BSS.takeEnd suflen tag
+ | n <- 0 : havePrefixes
+ , let suflen = BSS.length tag - n]) $ do
+ -- lift $ putStrLn "yay determined end"
+ exitEarly (BSB.toLazyByteString (builder <> BSB.byteString bs)
+ ,ReachedTag)
+
+ let nextPrefixes =
+ nub $
+ [plen + BS.length bs -- continuations of partial matches
+ | plen <- havePrefixes
+ , BS.length bs < BSS.length tag - plen
+ , BSS.toShort bs == BSS.take (BS.length bs) (BSS.drop plen tag)]
+ ++
+ [n -- new matches
+ | n <- [1 .. min (BS.length bs) (BSS.length tag)]
+ , BSS.toShort (BS.takeEnd n bs) == BSS.take n tag]
+ -- lift $ putStrLn ("nextPrefixes = " ++ show nextPrefixes)
+ loop (yet + nread) nextPrefixes (builder <> BSB.byteString bs)
+ result <- execExitEarlyT (loop 0 [] mempty)
+ return $! result
diff --git a/src/IRC.hs b/src/IRC.hs
new file mode 100644
index 0000000..36cb1c3
--- /dev/null
+++ b/src/IRC.hs
@@ -0,0 +1,62 @@
+module IRC where
+
+import Control.Monad (forM_)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteString.Char8 as Char8
+import Data.Char
+import Network.IRC.Client
+-- import Network.IRC.Client.Events
+import Lens.Micro
+import Data.Text (Text)
+import qualified Data.Text as T
+
+
+connectIRC :: (Text -> Bool) -> (Text -> IO [Text]) -> IO ()
+connectIRC commandDetect msgFun = do
+ pass <- readFile "irc-password.txt"
+ let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+ let conn = tlsConnection (WithDefaultConfig (Char8.pack "irc.libera.chat") 6697)
+ & username .~ T.pack "yahb2"
+ & realname .~ T.pack "Bot operated by tomsmeding"
+ & password .~ Just (T.pack (trim pass))
+ & logfunc .~ stdoutLogger
+
+ let cfg = defaultInstanceConfig (T.pack "yahb2")
+ & handlers .~
+ (-- some of the standard handlers
+ [pingHandler
+ ,kickHandler
+ ,ctcpPingHandler
+ ,ctcpTimeHandler
+ ,ctcpVersionHandler
+ ,welcomeNick
+ ,joinHandler]
+ ++
+ -- our custom handlers
+ [noticeHandler
+ ,privmsgHandler commandDetect msgFun]
+ )
+
+ runClient conn cfg ()
+
+noticeHandler :: EventHandler s
+noticeHandler = EventHandler
+ (\ev -> case ev ^. message of
+ Notice _ (Right text)
+ | T.pack "now identified for" `T.isInfixOf` text
+ -> Just ()
+ _ -> Nothing)
+ (\_ () -> do
+ send $ Join (T.pack "#haskell"))
+
+privmsgHandler :: (Text -> Bool) -> (Text -> IO [Text]) -> EventHandler s
+privmsgHandler commandDetect msgFun = EventHandler
+ (\ev -> case ev ^. message of
+ Privmsg target (Right text)
+ | commandDetect text -> Just (target, text)
+ _ -> Nothing)
+ (\_ (target, text) -> do
+ msgs <- liftIO $ msgFun text
+ forM_ msgs $ \msg ->
+ send $ Privmsg target (Right msg))
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..ee11e92
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,41 @@
+module Main where
+
+import Control.Concurrent.MVar
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Ghci
+import IRC
+
+
+runInGhci :: Ghci -> Text -> IO (Ghci, [Text])
+runInGhci ghci message = do
+ (ghci', output) <- runStmtClever ghci (T.unpack message)
+ case output of
+ Error "" -> return (ghci', [T.pack "Error?"])
+ Error err -> return (ghci', [T.pack err])
+ Ignored -> return (ghci', [])
+ Return "" -> return (ghci', [T.pack "<no output>"])
+ Return s -> return (ghci', [T.pack s])
+
+main :: IO ()
+main = do
+ ghci0 <- makeGhci
+ ghcivar <- newMVar ghci0
+ connectIRC
+ (\t -> T.take 2 t == T.pack "% ")
+ (\recvmsg -> do
+ ghci <- takeMVar ghcivar
+ (ghci', msgs) <- runInGhci ghci (T.drop 2 recvmsg)
+ putMVar ghcivar ghci'
+ return msgs)
+
+ -- let loop :: Ghci -> IO ()
+ -- loop ghci = do
+ -- line <- getLine
+ -- (ghci', moutput) <- runStmtClever ghci line
+ -- case moutput of
+ -- Just output -> putStrLn $ "output = <" ++ output ++ ">"
+ -- Nothing -> putStrLn "oops"
+ -- loop ghci'
+ -- makeGhci >>= loop
diff --git a/yahb2.cabal b/yahb2.cabal
new file mode 100644
index 0000000..44877fc
--- /dev/null
+++ b/yahb2.cabal
@@ -0,0 +1,30 @@
+cabal-version: 2.0
+name: yahb2
+synopsis: Yet another yet another haskell bot
+version: 0.1.0.0
+license: MIT
+author: Tom Smeding
+maintainer: tom@tomsmeding.com
+build-type: Simple
+
+executable yahb2
+ main-is:
+ Main.hs
+ other-modules:
+ ExitEarly
+ Ghci
+ IRC
+ build-depends:
+ base >= 4.13 && < 4.15,
+ bytestring >= 0.11 && < 0.12,
+ irc-client >= 1.1.2.2 && < 1.2,
+ microlens >= 0.4.12 && < 0.5,
+ process >= 1.6.13.2 && < 1.7,
+ random >= 1.2.1.1 && < 1.3,
+ stm >= 2.5 && < 2.6,
+ text >= 2.0 && < 2.1,
+ transformers >= 0.5.6 && < 0.6,
+ utf8-string >= 1.0.2 && < 1.1
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall -O2
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 03:12:22 +0100