Initial

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