Initial

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