Get first stackoverflow chat message

FirstSOChatMessage.hs

module Main where

import Network.HTTP (simpleHTTP, getRequest, getResponseBody)
import Text.HTML.TagSoup
import Data.List (isInfixOf, isPrefixOf)

type Link   = String
type UserID = String

hostname = "http://chat.stackoverflow.com"

getDivText :: String -> [Tag String] -> String
getDivText m = innerText
             . takeWhile (~/= "</div>")
             . dropWhile (~/= m)

getURLContent :: Link -> IO String
getURLContent lnk = simpleHTTP (getRequest lnk) >>= getResponseBody

getMessages :: UserID -> IO Integer
getMessages uid = do

    contents <- getURLContent $ concat [ hostname
                                       , "/users/"
                                       , uid ]
                                                
    let count = getDivText "<div class=user-message-count-xxl>"
              $ (parseTags contents)
    
    return (read count)

getFirstMessagePage :: UserID -> IO String
getFirstMessagePage uid = searchLast "" . ceiling . (/100)
                      =<< (fmap fromIntegral $ getMessages uid) where
    
    searchLast body pg = do 

        let lnk = concat [ hostname
                         , "/users/"
                         , uid
                         , "/?tab=recent&pagesize=100&page="
                         , show pg ]
            
        body' <- getURLContent lnk

        if "monologue" `isInfixOf` body'
            then return body'
            else searchLast body (pg - 1)

getFirstMessage :: UserID -> IO Link
getFirstMessage ui = do
    
    page <- getFirstMessagePage ui

    let tags = filter step $ parseTags  page
        lnk  = fromAttrib "href" $ last tags
    
    return $ concat [ hostname, lnk ]

    where step t = isTagOpen t
                 && "/transcript" `isPrefixOf` fromAttrib "href" t 

main :: IO ()
main = do
    
    putStrLn "Enter user id:"
    uid <- getLine

    putStrLn "Fetching data..."
    lnk <- getFirstMessage uid

    putStrLn lnk