aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Ghci.hs45
-rw-r--r--src/IRC.hs10
-rw-r--r--src/Main.hs121
-rw-r--r--yahb2.cabal3
4 files changed, 148 insertions, 31 deletions
diff --git a/src/Ghci.hs b/src/Ghci.hs
index 97943db..953bf72 100644
--- a/src/Ghci.hs
+++ b/src/Ghci.hs
@@ -8,6 +8,9 @@ module Ghci (
runStmt,
runStmtClever,
terminateGhci,
+ ParseSettings(..),
+ parseSettingsReply,
+ parseSettingsPaste,
) where
import Control.Exception (catch, SomeException)
@@ -46,6 +49,18 @@ data Ghci = Ghci
, ghciStdout :: Handle
}
+data ParseSettings = ParseSettings
+ { psMaxOutputLen :: Int -- ^ How much date to return, at most (will add '...')
+ , psJoinLines :: Bool -- ^ Whether to join lines with ';'
+ }
+ deriving (Show)
+
+parseSettingsReply :: ParseSettings
+parseSettingsReply = ParseSettings 200 True
+
+parseSettingsPaste :: ParseSettings
+parseSettingsPaste = ParseSettings 50000 False
+
data Result a = Error String | Ignored | Return a
deriving (Show)
@@ -65,8 +80,8 @@ makeGhci = do
, ghciStdin = stdinH
, ghciStdout = pipeOut }
-runStmtClever :: Ghci -> String -> IO (Ghci, Result String)
-runStmtClever ghci line =
+runStmtClever :: Ghci -> ParseSettings -> String -> IO (Ghci, Result String)
+runStmtClever ghci pset line =
case dropWhile isSpace line of
':' : line1 -> case words (map toLower (dropWhile isSpace line1)) of
('!':_) : _ -> return (ghci, Ignored)
@@ -80,14 +95,14 @@ runStmtClever ghci line =
hFlush stdout
ghci' <- makeGhci
return (ghci', Return "")
- _ -> runStmt ghci line
- _ -> runStmt ghci line
+ _ -> runStmt ghci pset line
+ _ -> runStmt ghci pset line
where
startsWith :: String -> String -> Bool
long `startsWith` short = take (length short) long == short
-runStmt :: Ghci -> String -> IO (Ghci, Result String)
-runStmt ghci line = timeouting 2_000_000 (restarting (\g -> runStmt' g line)) ghci
+runStmt :: Ghci -> ParseSettings -> String -> IO (Ghci, Result String)
+runStmt ghci pset line = timeouting 2_000_000 (restarting (\g -> runStmt' g pset line)) ghci
timeouting :: Int -> (Ghci -> IO (Ghci, Result a)) -> Ghci -> IO (Ghci, Result a)
timeouting microseconds f ghci =
@@ -138,24 +153,28 @@ restarting f ghci = do
terminateGhci :: Ghci -> IO ()
terminateGhci ghci = terminateProcess (ghciProc ghci)
-runStmt' :: Ghci -> String -> IO String
-runStmt' ghci stmt = do
+runStmt' :: Ghci -> ParseSettings -> String -> IO String
+runStmt' ghci pset stmt = do
tag <- updatePrompt ghci
ghciPutStrLn (ghciStdin ghci) stmt
hFlush (ghciStdin ghci)
- (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag
+ let readmax = psMaxOutputLen pset + 200
+ (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just readmax) 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
+ return (formatOutput output) -- don't need to strip tag because we read more than the max output len
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
+ formatOutput output =
+ let output' | psJoinLines pset = replaceNewlines (dropBothSlow isSpace output)
+ | otherwise = output
+ in if length output' > psMaxOutputLen pset
+ then take (psMaxOutputLen pset - 3) output' ++ "..."
+ else output'
dropBothSlow f = reverse . dropWhile f . reverse . dropWhile f
replaceNewlines = concatMap (\case '\n' -> " ; " ; c -> [c])
diff --git a/src/IRC.hs b/src/IRC.hs
index 9d9a320..8a956d1 100644
--- a/src/IRC.hs
+++ b/src/IRC.hs
@@ -13,7 +13,7 @@ import Lens.Micro
import System.IO (hFlush, stdout)
-connectIRC :: (Text -> Bool) -> (Text -> IO [Text]) -> IO ()
+connectIRC :: (Text -> Maybe a) -> (a -> Text -> IO [Text]) -> IO ()
connectIRC commandDetect msgFun = do
pass <- readFile "irc-password.txt"
let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
@@ -55,14 +55,14 @@ noticeHandler = EventHandler
send $ Join (T.pack "#haskell")
send $ Join (T.pack "#haskell-offtopic"))
-privmsgHandler :: (Text -> Bool) -> (Text -> IO [Text]) -> EventHandler s
+privmsgHandler :: (Text -> Maybe a) -> (a -> Text -> IO [Text]) -> EventHandler s
privmsgHandler commandDetect msgFun = EventHandler
(\ev -> case ev ^. message of
Privmsg _ (Right text)
- | commandDetect text -> Just (ev ^. source, text)
+ | Just s <- commandDetect text -> Just (ev ^. source, text, s)
_ -> Nothing)
- (\_ (src, text) -> do
- msgs <- liftIO $ msgFun text
+ (\_ (src, text, s) -> do
+ msgs <- liftIO $ msgFun s text
let mtarget = case src of
User name -> Just name
Channel ch _ -> Just ch
diff --git a/src/Main.hs b/src/Main.hs
index 9987b29..8990efb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,25 @@
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Concurrent.MVar
+import Control.Exception (handle)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as Char8
+import qualified Data.ByteString.Lazy.Char8 as LChar8
+import Data.Maybe (maybeToList)
+import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy.Encoding as TLE
+import Data.Word (Word8)
+import qualified Network.HTTP.Client as N
+import qualified Network.HTTP.Client.TLS as N
+import qualified Network.HTTP.Types.Status as N
import System.Environment (getArgs)
import System.Exit (die)
import System.IO (hFlush, stdout)
@@ -12,36 +28,115 @@ import Ghci
import IRC
-runInGhci :: Ghci -> Text -> IO (Ghci, [Text])
-runInGhci ghci message = do
- (ghci', output) <- runStmtClever ghci (T.unpack message)
+urlQueryComponentEncode :: Text -> TL.Text
+urlQueryComponentEncode = TLB.toLazyText . foldMap f . BS.unpack . TE.encodeUtf8
+ where
+ f :: Word8 -> TLB.Builder
+ f c | c >= 0x80 = percent c
+ | otherwise = let spec = table `BS.index` fromIntegral c
+ in if spec == fromIntegral (fromEnum '%')
+ then percent c
+ else TLB.singleton (toEnum (fromIntegral spec))
+
+ percent :: Word8 -> TLB.Builder
+ percent c =
+ let n = fromIntegral c
+ in TLB.singleton '%' <> TLB.singleton (hexdigit (n `quot` 16))
+ <> TLB.singleton (hexdigit (n `rem` 16))
+
+ hexdigit :: Int -> Char
+ hexdigit n | n < 10 = toEnum (fromEnum '0' + n)
+ | otherwise = toEnum (fromEnum 'A' + n - 10)
+
+ -- obtained by observing what curl does
+ table :: BS.ByteString
+ table = Char8.pack $ concat
+ ["%%%%%%%%%%%%%%%%" -- 0x00 - 0x0f
+ ,"%%%%%%%%%%%%%%%%" -- 0x10 - 0x1f
+ ,"+%%%%%%%%%%%%-.%" -- !"#$%&'()*+,-./
+ ,"0123456789%%%%%%" -- 0123456789:;<=>?
+ ,"%ABCDEFGHIJKLMNO" -- @ABCDEFGHIJKLMNO
+ ,"PQRSTUVWXYZ%%%%i" -- PQRSTUVWXYZ[\]^_
+ ,"%abcdefghijklmno" -- `abcdefghijklmno
+ ,"pqrstuvwxyz%%%~%"] -- pqrstuvwxyz{|}~
+
+pastePostErrorString :: String
+pastePostErrorString = "Pasting failed, sorry -- use plain % instead"
+
+-- Given text to be pasted, return paste url if successful, error otherwise
+makePaste :: N.Manager -> Text -> IO (Either String Text)
+makePaste mgr bodytext =
+ let nreq = N.defaultRequest
+ { N.host = Char8.pack "paste.tomsmeding.com"
+ , N.port = 443
+ , N.secure = True
+ , N.method = Char8.pack "POST"
+ , N.path = Char8.pack "/paste"
+ , N.requestHeaders = [(fromString "Content-Type"
+ ,fromString "application/x-www-form-urlencoded")]
+ , N.requestBody = N.RequestBodyLBS $
+ LChar8.pack "expire=day&name1=&code1="
+ <> TLE.encodeUtf8 (urlQueryComponentEncode bodytext)
+ , N.redirectCount = 0 -- the redirect is precisely what we want to catch
+ }
+ in handle (\(e :: N.HttpException) -> print e >> return (Left pastePostErrorString)) $
+ N.withResponse nreq mgr $ \response -> do
+ case N.statusCode (N.responseStatus response) of
+ 303
+ | Just url <- lookup (fromString "location") (N.responseHeaders response)
+ -> return (Right (T.pack "https://paste.tomsmeding.com"
+ <> TE.decodeUtf8Lenient url))
+ 429 -> do
+ return (Left "Pastebin rate-limited")
+ _ -> do
+ putStrLn $ "Paste response status " ++ show (N.responseStatus response) ++ " /= 200"
+ return (Left pastePostErrorString)
+
+
+runInGhci :: Ghci -> ParseSettings -> Text -> IO (Ghci, Maybe Text)
+runInGhci ghci pset message = do
+ (ghci', output) <- runStmtClever ghci pset (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])
+ Error "" -> return (ghci', Just (T.pack "Error?"))
+ Error err -> return (ghci', Just (T.pack err))
+ Ignored -> return (ghci', Nothing)
+ Return "" -> return (ghci', Just (T.pack "<no output>"))
+ Return s -> return (ghci', Just (T.pack s))
+
+data ReqKind = Reply | Paste
+ deriving (Show)
mainIRC :: IO ()
mainIRC = do
ghci0 <- makeGhci
ghcivar <- newMVar ghci0
+ manager <- N.newTlsManager
connectIRC
- (\t -> T.take 2 t == T.pack "% ")
- (\recvmsg -> do
+ (\t -> if | T.take 2 t == T.pack "% " -> Just (Reply, T.drop 2 t)
+ | T.take 3 t == T.pack "%% " -> Just (Paste, T.drop 3 t)
+ | otherwise -> Nothing)
+ (\(kind, expression) recvmsg -> do
putStrLn $ "Responding to " ++ T.unpack recvmsg
hFlush stdout
ghci <- takeMVar ghcivar
- (ghci', msgs) <- runInGhci ghci (T.drop 2 recvmsg)
+ let pset = case kind of Reply -> parseSettingsReply
+ Paste -> parseSettingsPaste
+ (ghci', msgs) <- runInGhci ghci pset expression
putMVar ghcivar ghci'
- return msgs)
+ case kind of
+ Reply -> return (maybeToList msgs)
+ Paste -> case msgs of
+ Nothing -> return [T.pack "Nothing to paste"]
+ Just msg -> makePaste manager msg >>= \case
+ Left err -> return [T.pack err]
+ Right url -> return [url])
mainGHCI :: IO ()
mainGHCI = do
let loop :: Ghci -> IO ()
loop ghci = do
line <- getLine
- (ghci', moutput) <- runStmtClever ghci line
+ (ghci', moutput) <- runStmtClever ghci parseSettingsReply line
case moutput of
Return output -> putStrLn $ "output = <" ++ output ++ ">"
Ignored -> putStrLn "<ignored>"
diff --git a/yahb2.cabal b/yahb2.cabal
index 44877fc..6118010 100644
--- a/yahb2.cabal
+++ b/yahb2.cabal
@@ -17,6 +17,9 @@ executable yahb2
build-depends:
base >= 4.13 && < 4.15,
bytestring >= 0.11 && < 0.12,
+ http-client >= 0.7.11 && < 0.8,
+ http-client-tls >= 0.3.6.1 && < 0.4,
+ http-types >= 0.12.3 && < 0.13,
irc-client >= 1.1.2.2 && < 1.2,
microlens >= 0.4.12 && < 0.5,
process >= 1.6.13.2 && < 1.7,
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-21 13:56:23 +0100