{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeOperators, TypeFamilies, UndecidableInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances #-}
module Main where

import Control.Concurrent
import Control.Concurrent.Chan
import Control.Exception
import Control.Monad
import Control.Monad.State
import Data.List (isPrefixOf)
import Data.Monoid(Monoid(..),mconcat)
import Network.IRC
import Network
import System.IO
import HAppS.Data
import HAppS.Data.IxSet
import HAppS.State
import Prelude hiding (log)
import System.Environment (getArgs)

data User = User { username   :: String
                 , hostname   :: HostName
                 , servername :: HostName
                 , realname   :: String
                 }
          deriving (Eq, Ord, Read, Show)

newtype BotPart a = BotPart { unBotPart :: Message -> Chan Message -> IO a }

ircConnect :: HostName -> PortID -> UserName -> User -> IO Handle
ircConnect host port n u =
    do h <- connectTo host port
       hSetBuffering h LineBuffering
       hPutStrLn h (encode (nick n))
       hPutStrLn h (encode (user (username u) (hostname u) (servername u) (realname u)))
       return h

-- TODO: killSwitch is full of potential race conditions
simpleIRC :: HostName -> PortID -> UserName -> User -> [BotPart a] -> IO (IO (), Chan Message)
simpleIRC host port n u botParts =
    do h <- ircConnect host port n u
       outgoingChan <- newChan :: IO (Chan Message)
       incomingTid <- forkIO $ forever $ 
                      do msgStr <- hGetLine h
                         -- putStrLn $ "-> " ++ msgStr
                         case decode (msgStr ++ "\n") of
                           Nothing -> putStrLn "decode failed." >> return ()
                           (Just msg) -> do unBotPart (multi botParts) msg outgoingChan >> return ()
                                            return ()
       outgoingTid <- forkIO $ forever $
                      do msg <- readChan outgoingChan
                         -- putStrLn (encode msg)
                         hPutStrLn h (encode msg)
       let killSwitch = do putStrLn "killing incoming tid"
                           killThread incomingTid
                           writeChan outgoingChan (quit (Just "If you'd like to hear it I can sing it for you.")) -- this does not work, perhaps be the bot is notice registered with nickserv ? hrm, I saw it work *once*.
                           sleepTillEmpty outgoingChan -- race condition
                           putStrLn "sleeping 1 second"
                           threadDelay 1000000
                           -- putStrLn "flushing output"
                           -- hFlush h
                           -- threadDelay 1000000
                           putStrLn "killing outgoing tid"
                           killThread outgoingTid      -- between these lines

       return (killSwitch, outgoingChan)
    where
      sleepTillEmpty chan =
          do empty <- isEmptyChan chan
             if empty 
                then return ()
                else do putStrLn "chan not empty, sleeping..."
                        threadDelay 1000000
                        sleepTillEmpty chan

-- * BotPart Helpers

withChan :: (Chan Message -> IO a) -> BotPart a
withChan f =
    BotPart $ \ msg outChan -> f outChan

cmd :: String -> [BotPart a] -> BotPart ()
cmd cmdName handle =
    BotPart $ \msg@(Message _ cmdName' _) outChan ->
        if cmdName == cmdName'
           then unBotPart (multi handle) msg outChan
           else return ()

withSenderNick :: (String -> [BotPart a]) -> BotPart ()
withSenderNick handle =
    BotPart $ \msg@(Message (Just (NickName n _ _)) cmd params) outChan ->
        unBotPart (multi (handle n)) msg outChan

param :: String -> [BotPart a] -> BotPart ()
param str handle =
    BotPart $ \msg@(Message prefix cmd params) outChan ->
        case params of
          (p:ps) | p == str -> unBotPart (multi handle) (Message prefix cmd ps) outChan
          _ -> noHandle

withParam :: (String -> [BotPart a]) -> BotPart ()
withParam handle =
    BotPart $ \msg@(Message prefix cmd params) outChan ->
        case params of
          (p:ps) -> unBotPart (multi (handle p)) (Message prefix cmd ps) outChan
          _ -> noHandle

withMessage :: (Message -> [BotPart a]) -> BotPart ()
withMessage handle =
    BotPart $ \msg outChan -> unBotPart (multi (handle msg)) msg outChan

noHandle :: IO ()
noHandle = return ()

multi :: [BotPart a] -> BotPart ()
multi parts = 
    BotPart $ \msg outChan -> 
        mapM_ (\p -> forkIO $ ((unBotPart p) msg outChan >> return ())) parts


io :: IO a -> BotPart a
io action = BotPart $ \_ _ -> action

-- * Demo

$(deriveAll [''Read, ''Show, ''Eq, ''Ord, ''Default, ''Enum, ''Num]
 [d|
     newtype ConversationCount = ConversationCount Integer
   |])
instance Version ConversationCount
$(deriveSerialize ''ConversationCount)

$(deriveAll [''Read, ''Show, ''Eq, ''Ord, ''Default]
 [d|
     newtype FriendName = FriendName String
     data Friend = Friend FriendName ConversationCount
  |])

instance Version FriendName
$(deriveSerialize ''FriendName)
instance Version Friend
$(deriveSerialize ''Friend)

$(inferIxSet "Friends" ''Friend 'noCalcs [''FriendName,''ConversationCount])

instance Component Friends where
    type Dependencies Friends = End
    initialValue = fromList []

incFriend :: FriendName -> Update Friends ConversationCount
incFriend friendName =
    do friends <- get
       case getOne (friends @= friendName) of
         Nothing -> do put (insert (Friend friendName 1) friends)
                       return 1
         (Just (Friend friendName count)) -> 
             let cc = succ count
             in do put (updateIx friendName (Friend friendName cc) friends)
                   return cc

$(mkMethods ''Friends ['incFriend])

-- * GetShapr

$(deriveAll [''Read, ''Show, ''Eq, ''Ord, ''Default, ''Enum, ''Num]
 [d|
     newtype GetShapr = GetShapr { shaprCount ::  Integer }
   |])
instance Version GetShapr
$(deriveSerialize ''GetShapr)

instance Component GetShapr where
    type Dependencies GetShapr = End
    initialValue = 0

incGetShapr :: Update GetShapr Integer
incGetShapr = 
    do (GetShapr c) <- get
       let c' = c + 1
       put (GetShapr c')
       return c'

$(mkMethods ''GetShapr ['incGetShapr])

-- if you privmsg the bot, it only sends to the shapr!! message to you.


getShapr :: String -> String -> (String -> IO ()) -> IO ()
getShapr _ "get-shapr" printer =
    do c <- update IncGetShapr
       let msg = (" shapr!! (get-shapr has been used " ++ show c ++ if (c == 1) then " time.)" else " times.)")
       printer msg
getShapr _ _ _ = return ()


-- * Bot State

$(deriveAll [''Read, ''Show, ''Eq, ''Ord, ''Default]
 [d|
     data BotState = BotState
  |])

instance Version BotState
$(deriveSerialize ''BotState)

instance Component BotState where
    type Dependencies BotState = Friends :+: GetShapr :+: End
    initialValue = BotState

$(mkMethods ''BotState [])

entryPoint :: Proxy BotState
entryPoint = undefined




main :: IO ()
main =
    do [botName] <- getArgs
       bracket (startSystemStateMultimaster entryPoint) closeTxControl $ \ctl ->
           main2 ctl botName


main2 ctl botName =
    do logChan <- newChan
       logTID <- forkIO $ logThread logChan
       (killSwitch, outgoingChan) <- simpleIRC "irc.freenode.net" (PortNumber (fromIntegral (6667 :: Integer))) botName (User botName "n-heptane.com" "irc.freenode.net" "step bot") (impl logChan botName)
       log logChan "Running..."
       writeChan outgoingChan (joinChan "#stepbot")
       writeChan outgoingChan (joinChan "#haskell-blah")
       waitForTermination
       log logChan "Shutting down..."
       killSwitch
       log logChan "Goodbye."
       killThread logTID
       createCheckpoint ctl

logThread :: Chan String -> IO ()
logThread chan =
    do s <- readChan chan
       putStrLn s
       logThread chan

log :: Chan String -> String -> IO ()
log chan msg = writeChan chan msg


impl :: Chan String -> String -> [BotPart ()]
impl logChan botName =
    [ handlePing logChan
    , toBot botName hello
    , toBot botName getShapr
    , logIt logChan
    ]

logIt :: Chan String -> BotPart ()
logIt logChan =
    withMessage $ \msg -> [ io $ writeChan logChan (show msg) ]
{-
hello :: String -> BotPart ()
hello botName = 
    cmd "PRIVMSG"
      [ withParam $ \receiver ->
        [ withParam $ \msg ->
          [ withSenderNick $ \senderNick ->
            [ withChan $ \outChan -> 
                  if (receiver == botName) || ((botName ++ ":") `isPrefixOf` msg)
                  then do (ConversationCount c) <- update (IncFriend (FriendName senderNick))
                          let msg = (" hello " ++ senderNick ++ ". We have now talked " ++ show c ++ " " ++ if (c == 1) then "time." else "times.")
                          if (receiver == botName)
                            then writeChan outChan (privmsg senderNick msg)
                            else writeChan outChan (privmsg receiver msg)
                  else noHandle
            ]
          ]
        ]
      ]
-}

hello :: String -> String -> (String -> IO ()) -> IO ()
hello senderNick "hello" printer = 
    do (ConversationCount c) <- update (IncFriend (FriendName senderNick))
       let msg = (" hello " ++ senderNick ++ ". We have now talked " ++ show c ++ " " ++ if (c == 1) then "time." else "times.")
       printer msg
hello _ _ _ = return ()

handlePing :: Chan String -> BotPart ()
handlePing logChan =
    cmd "PING"
      [ withParam $ \daemon ->
        [ withChan $ \outChan ->
              do writeChan outChan (pong daemon)
                 log logChan ("ping pong: " ++ daemon)
        ]
      ]

toBot :: String -> (String -> String -> (String -> IO ()) -> IO ()) -> BotPart ()
toBot botName handle =
    cmd "PRIVMSG"
      [ withParam $ \receiver ->
        [ withParam $ \msg ->
          [ withSenderNick $ \senderNick ->
            [ withChan $ \outChan -> 
                  if receiver == botName
                     then handle senderNick msg (\m -> writeChan outChan (privmsg senderNick m))
                     else if ((botName ++ ": ") `isPrefixOf` msg)
                             then handle senderNick (drop 2 (dropWhile (/= ':') msg)) (\m -> writeChan outChan (privmsg receiver m))
                             else noHandle
            ]
          ]
        ]
      ]