From 68f3d87a106002f9e46f5cb57c7f83048040dc5e Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sat, 3 Dec 2022 22:22:32 +0100 Subject: Paste --- src/Main.hs | 121 +++++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 108 insertions(+), 13 deletions(-) (limited to 'src/Main.hs') 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 ""]) - 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 "")) + 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 "" -- cgit v1.2.3-70-g09d2