Maud stats

maudstats.hs

{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-}
module Main where

import Database.MongoDB
import Data.Text     (unpack)
import Data.Int      (Int64)
import Data.List     (groupBy, nub)
import Data.DateTime (DateTime, fromSeconds, toGregorian')
import Data.UnixTime (diffUnixTime, secondsToUnixDiffTime, fromEpochTime, udtSeconds)

type DateType = Int64 
type IPPair = (DateType, String)

--dbUrl = "database.jail"
dbUrl    = "localhost"
dbName   = "maud"
diffTime = 24 -- hours

run pipe = access pipe ReadStaleOk dbName

main = do
        pipe <- connect (host dbUrl)
        e <- run pipe postsWithIp 
        let pairs = pairIps e
        close pipe
        let visits = groupVisitsUniq pairs
        printAll visits

{-|
 - postsWithIp returns all the posts with an associated IP, sorted by date.
 -}
postsWithIp = find (select ["author.ip" =: ["$exists" =: True]] "posts") 
                { project = ["_id" =: 0, "author.ip" =: 1, "date" =: 1]
                , sort    = ["date" =: 1]
                } >>= rest

{-|
 - pairIps extracts a list of pairs (date, ip) from the documents
 -}
pairIps :: [Document] -> [IPPair]
pairIps [] = []
pairIps (doc:docs) | date /= Nothing && ip /= Nothing = let (Just d, Just i) = (date, ip)
                                                        in (d, i) : pairIps docs
                   | otherwise = pairIps docs
                   where
                   ip   = doc !? "author.ip"
                   date = doc !? "date"


{-|
 - allIps returns a list with all the IPs in the documents given, uniqued.
 -}
allIps :: [Document] -> [String]
allIps [] = []
allIps docs = nub $ map extractIp $ docs
              where
              extractIp doc = case doc !? "author.ip" of
                              Just v  -> v
                              Nothing -> ""

getDay :: DateType -> DateTime
getDay = fromSeconds . fromIntegral
              
isSameDay :: IPPair -> IPPair -> Bool
isSameDay (a, _) (b, _) = abs (a - b) < 86400

{-|
 - groupVisits takes a list [(date, ip)] and returns a list [(day, [(date, ip)])]
 - with the ips grouped by days.
 -}
groupVisits :: [IPPair] -> [(DateTime, [IPPair])]
groupVisits [] = []
groupVisits pairs = map pairWithDay $ groupBy isSameDay pairs
                    where
                    pairWithDay :: [IPPair] -> (DateTime, [IPPair])
                    pairWithDay [] = error "Empty list given to pairWithDay!"
                    pairWithDay list = (getDay . fst . head $ list, list)

{-|
 - Like groupVisits, but uniques IPs and returns but a [(day, [ip])]
 -}
groupVisitsUniq :: [IPPair] -> [(DateTime, [String])]
groupVisitsUniq pairs = map getIps $ groupVisits pairs
                        where
                        getIps :: (DateTime, [IPPair]) -> (DateTime, [String])
                        getIps (date, prs) = (date, nub $ map snd prs)

printAll :: (Show a) => [(DateTime, a)] -> IO ()
printAll [] = return ()
printAll ((date, p):pairs) = do 
                             putStr $ show $ toGregorian' date
                             putStr " "
                             print p
                             printAll pairs