replace toString by warp

1 files changed, 23 insertions, 6 deletions

diff --git a/main.hs b/main.hs
index 1dbec06..bc62770 100644
--- a/main.hs
+++ b/main.hs
@@ -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 [] ""