Paste

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])
 
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>"