mahoro-0.1.1: Main.hs

-- | Main.hs
-- Main module, contains running MACID and XMPP.

import Config
import Threads
import Help
import DB
import DBState

import Happstack.State
import Control.Concurrent
import System.Time
import Network
import Network.XMPP

import Data.Char
import Data.List
import Text.Regex.Posix


-- | Read config, run macid and run XMPP in another thread.
main = do
    cfs <- readConfig ".mahororc"
    putStrLn . ( "starting happs stare" ++ ) =<< time
    control <- startSystemState stateProxy -- start the HAppS state system

    putStrLn . ( "happs state started" ++ ) =<< time
    tid <- forkIO $ doNetwork cfs
    putStrLn . ( ( "XMPP started\n" ++
               "shut down with ctrl-c" ) ++) =<< time
    waitForTermination
    killThread tid
    putStrLn . ( "creating checkpoint: " ++ ) =<< time
    createCheckpoint control

    putStrLn .  ( "shutting down system: " ++ ) =<< time
    shutdownSystem control 
    putStrLn .  ( "exiting: " ++ ) =<< time
  where
    time = return . ("\ntime: " ++ ) . show  =<< getClockTime
    stateProxy :: Proxy DBWrap
    stateProxy = Proxy


-- | Open connection and run XMPP.
doNetwork :: (Config, Chans) -> IO ()
doNetwork (cf, chans) = withSocketsDo $ do
    c <- openStream (cserver cf)
    getStreamStart c

    runXMPP c $ do
       err <- startAuth (cusername cf) (cserver cf)
                       (cpassword cf) "mahoro"
       if err /= 0
         then error $ "can't auth: "++(show err)++" error"
         else liftIO $ putStrLn "connected"
       sendPresence
       handleVersion "mahoro: chans to xmpp gate" (cversion cf) "PumpleOS"
       liftIO $ forkIO $ runLoop c cf chans

       addHandler (isChat `conj` hasBody) (messageCB chans) True
       addHandler (isPresence `conj` isSubscribe) subscribeCB True
    closeConnection c
  where
    isSubscribe stanza = attributeMatches "type" (=="subscribe") stanza


-- | Subscribed user if he wants.
subscribeCB :: StanzaHandler
subscribeCB stanza = do
    let from = maybe "" id (getAttr "from" stanza)
    sendStanza $ XML "presence" [("to", from), ("type", "subscribed")] []


-- | Parse commands.
messageCB :: Chans -> StanzaHandler
messageCB chans stanza = do
    let from = maybe "" id (getAttr "from" stanza)
        jid = getBareJid from
        body = maybe "" id (getMessageBody stanza)

        args = words body
        args' = if null args
                  then args
                  else (map toLower $ head args):(tail args)

        parseArg arg f =
          case (readMaybe arg)::Maybe Int of
            Just val | val > 0 -> do
              db <- query GetDB
              let threads = getUserThreads (JID jid) db
              if val <= length threads
                then update $ f (fst $ threads!!(val - 1)) (JID jid)
                else return "Wrong number. Print `ls'."
            _ ->
              update $ f (URL arg) (JID jid)

    answer <- case args' of
        ["touch", url] ->
            if isCorrectURL url chans
              then update $ AddThread' (URL $ fixURL url) (JID jid)
              else return "Wrong url. Print `lsmod'."
        ["touch", url, descr] ->
            if isCorrectURL url chans
              then do let u = (URL $ fixURL url)
                          j = (JID jid)
                      update $ AddThread' u j
                      update $ SetDescription' descr u j
              else return "Wrong url. Print `lsmod'."

        ["rm", arg] -> parseArg arg DelThread'
        
        ["ln", arg] -> parseArg arg (SetDescription' "")
        ["ln", arg, descr] -> parseArg arg (SetDescription' descr)

        ["ls"] -> do
            db <- query GetDB
            let threads = getUserThreads (JID jid) db
                showTs = intercalate "\n" . map showL . zip [1..]
                showL (n, (u, d)) = show n++". "++show u++" "++d
            return $ "You've subscribed on:\n"++showTs threads

        ["lsmod"] -> do
            let chs = map (\(r, c) -> cname c++" ("++r++")") chans
            return $ "Avialable chans:\n"++intercalate "\n" chs

        ["logout"] -> do
            update $ Bye' (JID jid)
            sendStanza $ XML "presence" [("to", from),("type", "unsubscribed")]
                                        []
            return "Bye-bye."

        ["help"] -> return help
        ["info"] -> return info

        ["nya"] -> return $ "Nya-nya nya-nya nihao nya coda "++
                           "tsugeraha tsude karu saa!"

        -- temporary hack for db maintenance
        ["dump"] | jid == "anon0@jabber.ru" ->
            return . dumpDB =<< query GetDB

        _ -> return "Nyaaaa? Print \"help\"."

    -- block
    liftIO $ waitQSem q
    -- send
    if null answer
      then return ()
      else sendMessage from answer
    -- unblock
    liftIO $ signalQSem q


-- Helpers.

fixURL :: String -> String
fixURL url = if '#' `elem` url
               then reverse $ tail $ dropWhile (/='#') $ reverse url
               else url

isCorrectURL :: String -> Chans -> Bool
isCorrectURL url = any (\r -> (url =~ fst r)::Bool)

readMaybe :: (Read a) => String -> Maybe a
readMaybe str = if (not $ null rd) && (null leftStr) then Just val else Nothing
    where rd@(~[(val, leftStr)]) = reads str