diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Ghci.hs | 45 | ||||
| -rw-r--r-- | src/IRC.hs | 10 | ||||
| -rw-r--r-- | src/Main.hs | 121 |
3 files changed, 145 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]) @@ -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>" |