From 30e9ed96f3a7683f6a23e689f666ef4a8948e3be Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Tue, 14 Jun 2022 18:15:40 +0200 Subject: Initial --- .gitignore | 3 + README.md | 9 ++ bwrap-files/chroot-initialise.sh | 4 + bwrap-files/entry.sh | 6 ++ bwrap-files/make-chroot.sh | 31 +++++++ bwrap-files/start.sh | 45 ++++++++++ cabal.project | 7 ++ src/ExitEarly.hs | 40 +++++++++ src/Ghci.hs | 172 +++++++++++++++++++++++++++++++++++++++ src/IRC.hs | 62 ++++++++++++++ src/Main.hs | 41 ++++++++++ yahb2.cabal | 30 +++++++ 12 files changed, 450 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100755 bwrap-files/chroot-initialise.sh create mode 100755 bwrap-files/entry.sh create mode 100755 bwrap-files/make-chroot.sh create mode 100755 bwrap-files/start.sh create mode 100644 cabal.project create mode 100644 src/ExitEarly.hs create mode 100644 src/Ghci.hs create mode 100644 src/IRC.hs create mode 100644 src/Main.hs create mode 100644 yahb2.cabal 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 ""]) + 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 -- cgit v1.2.3-70-g09d2