happs-tutorial-0.8: src/ControllerStressTests.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
module ControllerStressTests where

import Happstack.Server
import Happstack.State
import Data.List
import Misc
import qualified MiscMap as M 
import Control.Monad
import Control.Monad.Trans
import Data.Maybe
import Text.ParserCombinators.Parsec
import qualified Data.ByteString.Char8 as B

import StateVersions.AppState1
import ControllerMisc
import System.IO
import View
import System.Time

-- insert a lot of data unrealistically
-- the datastore set gets set in one huge macid transaction

spAddDummyData :: (MonadIO m) => RenderGlobals -> ServerPartT m Response
spAddDummyData rglobs = 
  withRequest $ \_ -> do
    us <- query AskDatastore
    if M.null (users us)
       then do insertus ddDemo
               return $ tutlayoutU rglobs [] "dummydatainitialized"   
       else return $ tutlayoutU rglobs [("errormsg", failmsg)] "errortemplate"
  where failmsg = "initializeDummyData, for safety, only works if there is currently no data in app\
                   \Maybe you shouldd first do mv _local _local.bak to get any existing data out of the way." 

-- insert a lot of data, faster, but less realistically -- all the users are inserted at once
--stressTestOneBigInsert = stressTest' insertus

-- insert a lot of data more realistically
-- lots of little macid actions build up to the final datastore.
-- stressTest :: Int -> RenderGlobals -> WebT IO Response
--stressTest = stressTest' $ atomic_inserts
stressTest' :: (MonadIO m) => (String, Users -> m a) -> Int
               -> RenderGlobals -> m Response
stressTest' (fname,f) n rglobs = do
    startTime <- liftIO getClockTime
    (userRange,us) <- getUsers 10 n
    f us
    stressTestTime <- liftIO $ return . timeDiffToString =<< timeSince startTime
    liftIO $ putStrLn $ fname ++ " stresstest, " ++ (show n) ++ " users, elapsedtime: " ++ stressTestTime
    return $ tutlayoutU rglobs [("first",show . head $ userRange)
                                , ("last",show . last $ userRange)
                                , ("stressTestName",fname)
                                , ("testTime",stressTestTime)]
                                  "stresstestcompleted"


getUsers :: (MonadIO m) => Int -> Int -> m ([Int], Users)
getUsers jobsPerU n = do
        us <- return . M.toList . users =<< query AskDatastore
        -- something around here seems kinda slow
        let startNum = case ( mapMaybe ( getDummyNumber . B.unpack . unusername . fst ) us ) of
               [] -> 1
               xs -> (+1) . last . sort $ xs 
            userRange = [startNum..(startNum+n-1)]            
        return (userRange, (stresstestdata jobsPerU) userRange)


getDummyNumber :: String -> Maybe Int
getDummyNumber s =
  case parse parseDummyNumber "parseDummyNumber" s of
    Left _ -> Nothing
    Right i' -> Just i'


parseDummyNumber :: Parser Int
parseDummyNumber = do
  string "user"
  i <- safeRead =<< many digit
  eof
  return i

-- insert a whole mess of users -- less realistic, but maybe faster way
-- to see how website stands up with a large amount of macid data (does it work with 100000 users... let's see...)

insertus :: (MonadIO m) => Users -> m ()
insertus us = update . ( AddDummyData . users ) $ us

insertusAllJobs :: (MonadIO m) => Users -> m ()
insertusAllJobs = mapM_ insertuAllJobs . M.toList . users 

insertuAllJobs :: (MonadIO m) => (UserName, UserInfos) -> m ()
insertuAllJobs (u, uis) = do
  update (AddDummyUser (u,uis)) 
  liftIO $ putStrLn $ "insertuAllJobs, added user: " ++ ( B.unpack . unusername $ u)
-- insert a user realistically 
-- follow the same macid steps that would occur when data is added by a human
atomic_inserts :: (MonadIO m) => Users -> m ()
atomic_inserts = mapM_ insertu . M.toList . users

insertu :: (MonadIO m) => (UserName, UserInfos) -> m ()
insertu (u, UserInfos pass pr (Jobs js) ) = do
  update $ AddUser u (B.pack . scramblepass . B.unpack $ pass)
  update $ SetUserProfile u pr
  mapM_ (\(jn,j) -> update $ AddJob u jn j) ( M.toList js )
  liftIO $ putStrLn $ "insertu, added user: " ++ ( B.unpack . unusername $ u)
    
                    
--------------dummy data
-- create arbitrarily large numbers of users to attempt insertion
--stresstestdata :: (Integral a) => [a] -> Users

stresstestdata :: (Integral a) => a -> [a] -> Users
stresstestdata jobsperU us = Users $ M.fromList $ map (stresstestUser jobsperU) us

stresstestUser :: (Integral a) => a -> a -> (UserName, UserInfos)
stresstestUser jobsperU i = ( UserName . B.pack $ ("user"++(show i))  
                     , UserInfos 
                        ( B.pack $ "password" ++ (show i))
                        (stresstestprofile i)
                        (Jobs $ M.fromList $ map (stresstestjob i) [1..jobsperU]) )
  where stresstestprofile x = UserProfile { contact = B.pack $ "someone" ++ (show x) ++ "@somewhere.com"
                                                  , blurb = B.pack "la la la"
                                                  , consultant = even x
                                                  , avatar = B.pack ""}
        stresstestjob x j = ( JobName . B.pack $ "make something " ++ (show (x,j)) ,
                              Job { jobbudget = B.pack . show $ (x,j)
                                  , jobblurb = B.pack . ("blurb " ++) . show $ (x,j) } ) 
                            

-- dummy data appropriate for a job site demo and testing
-- tphyahoo is consultant type user (wants to find work)
-- zzz posted a lot of test jobs
ddDemo :: Users
ddDemo = Users $ M.fromList [
  ( UserName . B.pack $ "tphyahoo", UserInfos (B.pack . scramblepass $ "password") tphyahooProfile tphyahooJobs )
  , ( UserName . B.pack $ "zzz", UserInfos (B.pack . scramblepass $ "password")
                                         (UserProfile ( B.pack "") ( B.pack "") False ( B.pack "")) serpinskiJobs )
  ] 

tphyahooProfile :: UserProfile
tphyahooProfile = UserProfile {
  --billing_rate = "it depends on the project"
  contact = B.pack "thomashartman1 at gmail, +48 51 365 3957"
  -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.
  , blurb = B.pack "I'm currently living in poland, doing a software sabbatical where I'm \
             \learning new things and writing and releasing open source software, including this tutorial."
  , consultant = True 
  , avatar = B.pack ""
}


-- can't use dummy data with foreign chars
-- app seems to accept them when entered through form though.
--               , ("Umläute in Happs benutzen können", "umsonst?")
tphyahooJobs :: Jobs
tphyahooJobs =
  Jobs $ M.fromList $ map (\(j,b)-> ( JobName . B.pack $ j, Job { jobbudget = B.pack b, jobblurb = B.pack $ "make " ++ j ++ " using HAppS "} ) )
             [ ("darcshub", "$5000")
              , ("community wizard", "$500,000")
              , ("hpaste in happs", "karma points?")
              , ("facebook clone", "$10,000")
              , ("rentacoder clone", "12,000 Eu")
              , ("ebay clone", "")
              , ("reddit clone", "")
              , ("ripplepay clone", "best offer")
              , ("oscommerce clone", "$1500")
              , ("phpbb clone", "")
              , ("sql-ledger clone", "")]

serpinskiJobs :: Jobs
serpinskiJobs =  Jobs $ M.fromList $ map (\num -> ( JobName . B.pack $ "job" ++ (show num), Job ( B.pack "$0") ( B.pack "")) ) [10..203]