diff options
| -rw-r--r-- | main.hs | 29 |
1 files changed, 23 insertions, 6 deletions
@@ -8,6 +8,12 @@ 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" @@ -21,6 +27,9 @@ server_hostname = "ni.r" server_port :: PortNumber server_port = 6667; +warp_port :: Int +warp_port = 10080 + main :: IO () main = withSocketsDo $ do @@ -38,7 +47,7 @@ talk h = do hSetNewlineMode h universalNewlineMode hSetBuffering h LineBuffering handshake h - _ <- race fromServer toServer + _ <- race fromServer (warp h) return () where fromServer = forever $ do @@ -48,8 +57,16 @@ talk h = do hPutStrLn h (unpack (replace "PING" "PONG" (pack line))) else print line - toServer = do - line <- getLine - case line of - ":quit" -> do hPutStrLn h "/quit"; return () - _ -> do hPutStrLn h ("PRIVMSG " ++ chan ++ " :" ++ line); toServer + +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 [] "" |