Added Auth handler

.gitignore

@@ -7,3 +7,5 @@ config.cfg
 *sublime*
 logs
 stats
+state
+TODO

Network/IRC/Handlers.hs

@@ -7,6 +7,7 @@ module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
 
 import qualified Network.IRC.Handlers.MessageLogger as L
 import qualified Network.IRC.Handlers.SongSearch as SS
+import qualified Network.IRC.Handlers.Auth as A
 
 import ClassyPrelude
 import Control.Concurrent.Lifted  (Chan)
@@ -31,7 +32,7 @@ mkMsgHandler _ _ "pingpong" = do
   return . Just $ newMsgHandler { onMessage = pingPong state }
 
 mkMsgHandler botConfig eventChan name =
-  flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler] $ \acc h ->
+  flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler, A.mkMsgHandler] $ \acc h ->
     case acc of
       Just _  -> return acc
       Nothing -> h botConfig eventChan name

Network/IRC/Handlers/Auth.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Network.IRC.Handlers.Auth (mkMsgHandler) where
+
+import qualified Data.UUID as U
+import qualified Data.UUID.V4 as U
+
+import ClassyPrelude
+import Control.Concurrent.Lifted (Chan)
+import Control.Monad.Reader      (asks)
+import Control.Monad.State       (get, put)
+import Data.Acid                 (AcidState, Query, Update, makeAcidic, openLocalState)
+import Data.Acid.Advanced        (query', update')
+import Data.Acid.Local           (createCheckpointAndClose)
+import Data.SafeCopy             (base, deriveSafeCopy)
+
+import Network.IRC.Handlers.Auth.Types
+import Network.IRC.Types
+
+emptyAuth :: Auth
+emptyAuth = Auth mempty
+
+$(deriveSafeCopy 0 'base ''Auth)
+
+getToken :: Nick -> Query Auth (Maybe Token)
+getToken user = lookup user <$> asks auth
+
+saveToken :: Nick -> Token -> Update Auth ()
+saveToken user token = get >>= put . Auth . insertMap user token . auth
+
+deleteToken :: Nick -> Update Auth ()
+deleteToken user = get >>= put . Auth . deleteMap user . auth
+
+$(makeAcidic ''Auth ['getToken, 'saveToken, 'deleteToken])
+
+issueToken :: AcidState Auth -> Nick -> IO Token
+issueToken acid user = do
+  mt <- query' acid (GetToken user)
+  case mt of
+    Just t -> return t
+    Nothing -> do
+      token <- map (pack . U.toString) U.nextRandom
+      update' acid (SaveToken user token)
+      return token
+
+authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m (Maybe Command)
+authMessage state PrivMsg { .. }
+  | "token" `isPrefixOf` msg = liftIO $ do
+      acid  <- readIORef state
+      token <- issueToken acid (userNick user)
+      return . Just $ PrivMsgReply user token
+authMessage _ _ = return Nothing
+
+stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
+stopAuth state = liftIO $ readIORef state >>= createCheckpointAndClose
+
+authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> SomeEvent -> m EventResponse
+authEvent state event = case fromEvent event of
+  Just (AuthEvent user token reply, _) -> liftIO $ do
+    acid <- readIORef state
+    mt <- query' acid (GetToken user)
+    case mt of
+      Just t  -> putMVar reply (t == token)
+      Nothing -> putMVar reply False
+    return RespNothing
+  _                                 -> return RespNothing
+
+mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
+mkMsgHandler _ _ "auth" = do
+  state <- liftIO (openLocalState emptyAuth >>= newIORef)
+  return . Just $ newMsgHandler { onMessage = authMessage state
+                                , onEvent   = authEvent state
+                                , onStop    = stopAuth state }
+mkMsgHandler _ _ _                       = return Nothing

Network/IRC/Handlers/Auth/Types.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Network.IRC.Handlers.Auth.Types where
+
+import ClassyPrelude
+import Data.Data (Data)
+
+import Network.IRC.Types hiding (user)
+
+type Token = Text
+newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeable)
+
+data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
+instance Event AuthEvent
+instance Show AuthEvent where
+  show (AuthEvent user token _) = "AuthEvent[" ++ unpack user ++ ", " ++ unpack token ++ "]"

Network/IRC/Protocol.hs

@@ -60,6 +60,6 @@ lineFromCommand BotConfig { .. } command = case command of
   JoinCmd                         -> Just $ "JOIN " ++ channel
   QuitCmd                         -> Just "QUIT"
   ChannelMsgReply { .. }          -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
-  PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ botNick ++ " :" ++ rmsg
+  PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ userNick ++ " :" ++ rmsg
   NamesCmd                        -> Just $ "NAMES " ++ channel
   _                               -> Nothing

config.cfg.template

@@ -2,7 +2,7 @@ server = "irc.freenode.net"
 port = 6667
 channel = "#testtesttest"
 nick = "haskman"
-msghandlers = ["greeter", "welcomer", "songsearch"]
+msghandlers = ["greeter", "welcomer", "songsearch", "auth"]
 
 songsearch {
   tinysong_apikey = "xxxyyyzzz"

hask-irc.cabal

@@ -69,7 +69,11 @@ library
                        unix              >=2.7,
                        convertible       >=1.1,
                        hslogger          >=1.2.4,
-                       hslogger-template >=2.0
+                       hslogger-template >=2.0,
+                       ixset             >=1.0,
+                       acid-state        >=0.12,
+                       safecopy          >=0.8,
+                       uuid              >=1.3
 
   exposed-modules:     Network.IRC.Types, Network.IRC.Protocol,
                        Network.IRC.Handlers, Network.IRC.Client
@@ -108,7 +112,11 @@ executable hask-irc
                        unix              >=2.7,
                        convertible       >=1.1,
                        hslogger          >=1.2.4,
-                       hslogger-template >=2.0
+                       hslogger-template >=2.0,
+                       ixset             >=1.0,
+                       acid-state        >=0.12,
+                       safecopy          >=0.8,
+                       uuid              >=1.3
 
   -- Directories containing source files.
   -- hs-source-dirs: