diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ExitEarly.hs | 40 | ||||
| -rw-r--r-- | src/Ghci.hs | 172 | ||||
| -rw-r--r-- | src/IRC.hs | 62 | ||||
| -rw-r--r-- | src/Main.hs | 41 |
4 files changed, 315 insertions, 0 deletions
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 |