{-# 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)
  talk h `finally` hClose h

handshake :: Handle -> IO ()
handshake h = do
    hPutStrLn h ("NICK " ++ nick)
    hPutStrLn h ("USER " ++ nick ++ " * 0 :" ++ nick)
    hPutStrLn h ("JOIN " ++ chan)

talk :: Handle -> IO ()
talk h = do
    hSetNewlineMode h universalNewlineMode
    hSetBuffering h LineBuffering
    handshake h
    _ <- race fromServer (warp h)
    return ()
  where
    fromServer = forever $ do
      line <- hGetLine h
      --case line of
      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 [] ""