1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{-# 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)
import Ghci
import IRC
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', 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))
Exited -> return (ghci', Just (T.pack "<bye>"))
data ReqKind = Reply | Paste
deriving (Show)
mainIRC :: IO ()
mainIRC = do
ghci0 <- makeGhci
ghcivar <- newMVar ghci0
manager <- N.newTlsManager
connectIRC
(\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
let pset = case kind of Reply -> parseSettingsReply
Paste -> parseSettingsPaste
(ghci', msgs) <- runInGhci ghci pset expression
putMVar ghcivar ghci'
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 parseSettingsReply line
case moutput of
Return output -> putStrLn $ "output = <" ++ output ++ ">"
Ignored -> putStrLn "<ignored>"
Error err -> putStrLn err
Exited -> putStrLn $ "<exited>"
loop ghci'
makeGhci >>= loop
main :: IO ()
main = do
getArgs >>= \case
["-irc"] -> mainIRC
["-ghci"] -> mainGHCI
[] -> mainGHCI
_ -> die "Command line not recognised"
|
