Bot for browser mmorpg botva.ru written in Haskell

BotvaBot.hs

{-- 
    kreed131.blogspot.com
--}

import           Prelude hiding (catch)
import           Data.Char (isDigit)
import           Data.Maybe (fromMaybe)
import qualified Data.Map as M (lookup)
import           System.IO
import           System.Random (randomRIO)
import           Control.Concurrent (threadDelay)
import           Control.Exception (catch, SomeException)

import           Data.String.Utils (split, startswith)
import           Network.Shpider
import           Network.Shpider.State
import           Network.Curl.Opts
import           Text.HTML.TagSoup

data BotvaAccount = BAccount {
      server   :: Int
    , email    :: String
    , password :: String
    } deriving(Show)

data Work a = CanWork | WaitForWork a
              deriving(Show, Eq)

data WorkType = Bodalka | Farm | Fishing
              deriving(Show, Eq)

data Fight a = CanFight | WaitForFight a
             deriving(Show, Eq)

data CharacterState = CharState {
      work    :: Work Int
    , fishing :: Work Int
    , fight   :: Fight Int
    } deriving(Show)

data BotvaCharacter = BCharacter {
      nickname     :: String
    , lvl          :: Int 
    , strength     :: Int
    , defence      :: Int 
    , dexterity    :: Int
    , weight       :: Int
    , skill        :: Int
    , hp           :: (Int, Int)
    , xp           :: (Int, Int)
    , glory        :: Int
    , charState    :: CharacterState
    , regen        :: Int
    , dozorRemTime :: Int
    } deriving(Show)


{--
--- Parsing and working with network ---
--}

main :: IO ()
main = do 
  hSetBuffering stdout NoBuffering
  runBot

runBot :: IO ()
runBot = catch bot rest
    where 
      rest :: SomeException -> IO ()
      rest _ = runBot

twentySpaces :: String
twentySpaces = replicate 20 ' '

putMsg, putMsgLn :: String -> IO ()
putMsg   = putStr . ("\r" ++) . (++ twentySpaces)
putMsgLn = putStrLn . ("\r" ++) . (++ twentySpaces)

bot :: IO ()
bot = bot' 1                   
    where
      bot' :: Int -> IO ()
      bot' i = do
        putStrLn $ "\n" ++ show i ++ " iteration."
        loginIn >> smallPause
        stats <- getMyStats
        when (i `mod` 15 == 0) $ print stats
        let charState' = charState stats
        let canWork    = work charState' == CanWork && snd (checkHP stats)
        let canFight   = fight charState' == CanFight && fst (checkHP stats) && canWork
        let canFish    = fishing charState' == CanWork
        let workType'  = workType stats
        when' canFight "Fight!" $ findAndFight stats
        when' canWork ("Work on " ++ show workType' ++ "!") $ goWork (workTime workType') workType'
        when' canFish "Fishing!" $ goWork 0 Fishing
        stats <- getMyStats
        print $ timeForWaitList stats
        putMsgLn "Wait!" >> bigPause >> (waitWithProgress . minimum' . filter (> 0) . timeForWaitList) stats
        bot' (i + 1)

timeForWaitList :: BotvaCharacter -> [Int]
timeForWaitList stats = [fromWaitWork (work charState'), fromWaitWork (fishing charState'), fromWaitFight (fight charState')]
    where charState' = charState stats

when' :: Bool -> String -> IO () -> IO ()
when' p s x = when p $ putMsgLn s >> x >> smallPause

minimum' :: [Int] -> Int
minimum' xs = if null xs then 0 else minimum xs

loginIn :: IO ()
loginIn = runShpiderWithMyState $ do
            src <- download $ gameUrl "index.php"
            let form = forms $ snd src
            unless (null form) $ 
                 sendForm (fillOutForm (head form) [("email", email myAcc), ("password", password myAcc)]) 
                              >> return ()

findAndFight :: BotvaCharacter -> IO ()
findAndFight stats = findAndFight' 0
    where findAndFight' i = when (i < 5) $ 
                            findOpponent (lvl stats - 1) (lvl stats + 1) 
                            >>= \(f,o) -> if sumOfStats stats / sumOfStats (getStats o) >= compareCoeff
                                         then goFight f
                                         else findAndFight' (i + 1)


getMyStats :: IO BotvaCharacter
getMyStats = runShpiderWithMyState $ do
             tgs <- downloadTags $ gameUrl "index.php"
             lift smallPause
             doz <- downloadTags $ gameUrl "dozor.php"
             lift smallPause
             fishingState <- lift getFishingState
             let fightState = fromJsTimer (~== "<a class='timer attack'>") tgs
             let workState  = fromJsTimer (~== "<a class='timer link'>") tgs
             let person = BCharacter { 
                            nickname = select 5 (~== "<div class=name>") tgs
                          , lvl = read (select 3 (~== "<td class='c2 left'>") tgs) :: Int
                          , strength = selectStats 0 tgs
                          , defence = selectStats 1 tgs
                          , dexterity = selectStats 2 tgs
                          , weight = selectStats 3 tgs
                          , skill = selectStats 4 tgs
                          , hp = (head (parseExpHP "ico_hits" tgs), parseExpHP "ico_hits" tgs !! 1)
                          , xp = (head (parseExpHP "ico_exp" tgs),  parseExpHP "ico_exp" tgs !! 1)
                          , glory = read (select 6 (~== "<b class='icon ico_glory'>") tgs) :: Int
                          , charState = CharState 
                                        (if workState == 0 then CanWork else WaitForWork workState) 
                                        fishingState
                                        (if fightState == 0 then CanFight else WaitForFight fightState)
                          , regen = read (parseRegen tgs) :: Int
                          , dozorRemTime = if fromWaitWork (work $ charState person) == 0 && snd (checkHP person)
                                           then read (filter isDigit $ select 4 
                                                      (~== "<input type=submit class='cmd_all \
                                                           \cmd_row3 cmd_arow3 ' value = '\205\192\215\192\210\220'>") 
                                                      doz) :: Int
                                           else -10
                          }
             return person

getStats :: [Tag String] -> BotvaCharacter
getStats p = BCharacter { nickname = drop 4 $ select 4 (~== "<div class=blockTitle>") p
                        , lvl = read (select 3 (~== "<td class='c2 left'>") p) :: Int
                        , strength = selectStats 0 p
                        , defence = selectStats 1 p
                        , dexterity = selectStats 2 p
                        , weight = selectStats 3 p
                        , skill = selectStats 4 p
                        , hp = (0,0) 
                        , xp = (0,0)
                        , glory = read (select 7 (~== "<b class='icon ico_glory'>") p) :: Int
                        , charState = CharState CanWork CanWork CanFight
                        , regen = 0
                        , dozorRemTime = -10
                          }

sumOfStats :: BotvaCharacter -> Double
sumOfStats x = toEnum (sum [strength x, defence x, dexterity x, weight x, skill x]) :: Double

getFishingState :: IO (Work Int)
getFishingState = runShpiderWithMyState $ do
                    tgs     <- downloadTags $ gameUrl "harbour.php?a=pier"
                    rndTime <- lift (randomRIO (75, 225) :: IO Int) 
                    let button = partitions (~== "<input type=submit class='cmd_all cmd_large cmd_alarge ' value='\206\210\207\208\192\194\200\210\220'>") tgs
                    let timer  = head $ partitions (~== "<center>") tgs
                    let fishingState | not (null button)   = CanWork
                                     | length timer == 32 = WaitForWork $ (fromBTimer . fromTagText . (!!8))  timer
                                     | otherwise         = WaitForWork rndTime
                    return fishingState

findOpponent :: Int -> Int -> IO (Form, [Tag String])
findOpponent mi ma = runShpiderWithMyState $ do
                       src <- download $ gameUrl "dozor.php"
                       let form = forms (snd src) !! 1
                       let k    = fromMaybe "" $ M.lookup "k" (inputs form)
                       let form' = mkForm "dozor.php" POST [("k", k), ("min", show mi), ("max", show ma), ("do_search", "1"), ("type", "advanced")]
                       r <- fmap snd $ sendForm form'
                       return (head (forms r), tags r)

goFight :: Form -> IO ()
goFight oppForm = runShpiderWithMyState $ sendForm oppForm >> return ()

goWork :: Double -> WorkType -> IO ()
goWork time t = runShpiderWithMyState $ do
                  src <- case t of 
                          Bodalka -> download $ gameUrl "dozor.php"
                          Farm    -> download $ gameUrl "farm.php"
                          Fishing -> download $ gameUrl "harbour.php?a=pier"
                  let form = (head . forms . snd) src
                  let k    = fromMaybe "" $ M.lookup "k" (inputs form)
                  let form' = case t of 
                                Bodalka -> mkForm "dozor.php" POST [("k", k), ("auto_watch", show $ floor $ time / 10)]
                                Farm    -> mkForm "farm.php" POST [("k", k), ("work", show $ floor $ time / 60), ("cmd", "do")]
                                Fishing -> mkForm "harbour.php?a=pier" POST [("k", k), ("do_cmd", "send")] 
                  fmap snd $ sendForm form'
                  return ()

{--
--- Helpers ---
--}

workType :: BotvaCharacter -> WorkType
workType stats = if dozorRemTime stats > 0 then Bodalka else Farm

workTime :: Fractional a => WorkType -> a
workTime wType = case wType of
                   Bodalka -> 10.0
                   _       -> 60.0
 
smallPause :: IO ()
smallPause = do 
  rndTime <- randomRIO (5,40) :: IO Int
  waitWithProgress rndTime

bigPause :: IO ()
bigPause = do
  rndTime <- randomRIO (35, 175) :: IO Int
  waitWithProgress rndTime

fromWaitWork :: Num t => Work t -> t
fromWaitWork  (WaitForWork x)  = x
fromWaitWork  CanWork          = 0

fromWaitFight :: Num t => Fight t -> t
fromWaitFight (WaitForFight x) = x
fromWaitFight CanFight         = 0

waitFor :: Int -> IO ()
waitFor = threadDelay . (* 1000000)

waitWithProgress :: Int -> IO ()
waitWithProgress x = do
  putMsg ("Wait for: " ++ show x ++ " sec")
  waitFor 1
  when (x > 0) $ waitWithProgress (x - 1)

checkHP :: BotvaCharacter -> (Bool, Bool)
checkHP = (\(x,y) -> (,) ((fromIntegral x / fromIntegral y) > hpCoeff) (x > 25) ) . hp

{-- Parsing helpers --}

clean :: String -> String
clean = unwords . words

select :: Int -> (Tag String -> Bool) -> [Tag String] -> String
select = select' 0

select' :: Show str => Int -> Int -> (Tag str -> Bool) -> [Tag str] -> str
select' y x p = fromTagText . (!! x) . (!! y) . partitions p

selectStats :: Int -> [Tag String] -> Int
selectStats x t = read (select' x 1 (~== "<td class=c4>") t) :: Int

fromTimer :: String -> Int
fromTimer    = (\[x,y,z] -> x*24*60 + y*60 + z) . map read . split ":" 

fromBTimer :: String -> Int
fromBTimer x = if length x == 8 then fromTimer x else 0

fromJsTimer' :: Show str => [[Tag str]] -> str
fromJsTimer' x = if isTagText first then fromTagText first else fromTagText second
                  where first  = head x !! 1
                        second = head x !! 2 

fromJsTimer :: (Tag String -> Bool) -> [Tag String] -> Int
fromJsTimer p = fromBTimer . fromJsTimer' . partitions p

parseExpHP :: String -> [Tag String] -> [Int]
parseExpHP t = map (\x -> read x :: Int) . split "/" . clean . 
               dropWhile (/= ' ') . clean . 
               select 2 (~== ("<b class='icon " ++ t ++ "'>"))

parseRegen :: [Tag String] -> String
parseRegen = filter isDigit . concat . filter (startswith "speed") . split ";" . 
             fromAttrib "onMouseOver" . head . head . partitions (~== "<div class=char_stat>")

{-- Shpider state performer --}

downloadTags :: String -> StateT ShpiderState IO [Tag String]
downloadTags = fmap (tags . snd) . download

runShpiderWithMyState :: StateT ShpiderState IO a -> IO a
runShpiderWithMyState = runShpider . (put myState >>) 

{-- States and configs --}

hpCoeff, compareCoeff :: Double
hpCoeff = 0.7
compareCoeff = 1.5

gameUrl :: String -> String
gameUrl x = concat ["http://g", show (server myAcc), ".botva.ru/", x]

myAcc :: BotvaAccount
myAcc = BAccount {
          server   = 3
        , email    = "YOUR@EMAIL.com"
        , password = "YOUR_PASSWORD"
        }

pmyState :: ShpiderState
myState = SS { startPage = ""
             , htmlOnlyDownloads = False
             , dontLeaveDomain = False
             , curlOpts = [ CurlCookieFile "cookies"
                          , CurlCookieJar "cookies"
                          , CurlUserAgent "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/534.27 (KHTML, like Gecko) Chrome/12.0.718.0 Safari/534.27"                      
                          ]
             , currentPage = emptyPage 
             , visited = Nothing 
             }