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
|
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (forever)
import Network (withSocketsDo, PortID(..), connectTo)
import Network.Socket (HostName, PortNumber)
import System.IO (hSetBuffering, hSetNewlineMode, hPutStrLn, hClose, hGetLine, BufferMode(LineBuffering), universalNewlineMode, Handle)
import Control.Concurrent.Async (race)
import Control.Exception.Base (finally)
import Data.Text (isPrefixOf, pack, replace, unpack)
import qualified Data.ByteString.Char8 as BS8
import Network.Wai (requestBody, requestMethod, responseLBS)
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types (status200, status404)
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Types.Method (methodPost)
nick :: String
nick = "ni"
chan :: String
chan = "#retiolum"
server_hostname :: HostName
server_hostname = "ni.r"
server_port :: PortNumber
server_port = 6667;
warp_port :: Int
warp_port = 10080
main :: IO ()
main = withSocketsDo $ do
h <- connectTo server_hostname (PortNumber server_port)
(`finally` hClose h) $ do
hSetNewlineMode h universalNewlineMode
hSetBuffering h LineBuffering
handshake h >> race (fromServer h) (warp h) >>= print
handshake :: Handle -> IO ()
handshake h = do
hPutStrLn h ("NICK " ++ nick)
hPutStrLn h ("USER " ++ nick ++ " * 0 :" ++ nick)
hPutStrLn h ("JOIN " ++ chan)
fromServer :: Handle -> IO ()
fromServer h = forever $ do
line <- hGetLine h
if (isPrefixOf "PING" (pack line)) then
hPutStrLn h (unpack (replace "PING" "PONG" (pack line)))
else
print line
warp :: Handle -> IO ()
warp h =
run warp_port app
where
app req f =
if requestMethod req == methodPost
then do
s <- requestBody req
hPutStrLn h ("PRIVMSG " ++ chan ++ " :" ++ BS8.unpack s)
f $ responseLBS status200 [(hContentType, "text/plain")] "OK"
else do
f $ responseLBS status404 [] ""
|
