Paste

1 files changed, 108 insertions, 13 deletions

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