When writing tests for different programming structures it is often necessary to feed the tests data in some sort of systematic way. There are libraries designed to do this but the heavy lifting required is often more than I am willing to attempt.
One thing I have noticed about designing these structures is they very quickly turn into mini-DSL's which make you think "apply parser here" however, I think almost all the situations where my configurations could have been DSL are just as well suited to JSON with a few built in tokens.
Attached below is the code I use to feed historical events into a local mongoDB for testing our website out. One of my favorite things about writing this little guy was seeing the natural way that a project that was supposed to just spit a random value, became one that was configurable, timeable, and programmable.
A few of my favorite things you can do...
Program any of the created datasources to emit a constant that changes after some fixed amount of time.
Transforming this from non-threaded to threaded haskell took place over 1 line of code. Just a parMapM. (Not shown)
{-# LANGUAGE BangPatterns,TupleSections, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, RecordWildCards, MultiParamTypeClasses, FlexibleInstances ,DeriveGeneric #-}
module MongoDataSeeder where
import Data.String
import Data.Text
import System.IO
import GHC.Generics
import Data.Typeable
import Data.Data
import Control.Parallel.Strategies
import Data.Time
import Text.Show
import Data.Yaml
import System.Random
import Data.Bool
import Data.Maybe
import qualified Debug.Trace as Bug
import Prelude
import Control.Monad
import Control.Monad.State.Strict
import Control.Applicative
import Control.Concurrent (threadDelay)
import qualified Data.ByteString as B
import qualified Data.Aeson.Bson as A2B
import qualified Data.Aeson.Generic as A
import Database.MongoDB
data MongoDBConfig = MongoDBConfig {
mHost :: Text
,mDatabase :: Text
,mCollection :: Text
,mDelay :: Int
,mPrint :: Bool
,mInsertProto :: B.ByteString
}
deriving (Generic,Show,Eq)
instance FromJSON MongoDBConfig
instance ToJSON MongoDBConfig
data FDInsert = FDInsert {getInsert::InsertDoc ,getMcfg::MongoDBConfig}
deriving (Show, Eq)
type InitialDoc = FDInsert
type DocState = FDInsert
type InsertState = (InitialDoc , DocState)
type IOState = IO InsertState
newStateGen :: IOState -> (IOState -> IOState)
newStateGen !m = (\x -> m)
runInserter :: StateT IOState IO DocState
runInserter = do
iDocState <- get
insertDocs@(iDoc,cDoc) <- liftIO $ iDocState
case done insertDocs of
True -> return.snd $ insertDocs
False -> do
rslt <- liftIO $ (threadDelay (mDelay.getMcfg $ iDoc))>>maybePrint cDoc>>insertData (snd insertDocs)
withStateT (newStateGen $ return (iDoc,rslt)) runInserter
maybePrint d
|(mPrint.getMcfg $ d) = print (getInsert d) >> putStr "\n"
| otherwise = return ()
done :: InsertState -> Bool
done ( _ ,FDInsert cDoc _) = let isDate (Date l) = Just l
isDate _ = Nothing
in (isDate.sType.start $ cDoc) >= (isDate.sType.stop $ cDoc)
insertData :: DocState -> IO DocState
insertData d@(FDInsert iDoc mdbCFG) = do
pipe <-runIOE $ connect (host.unpack.mHost $ mdbCFG)
rnd <- randomRIO (0,100)
fI <- mkInsert d
e <- access pipe UnconfirmedWrites (mDatabase mdbCFG) (fI rnd)
strt <- asDate.start $ iDoc
close pipe
return $ FDInsert (InsertDoc (iId iDoc) (step iDoc) (SeedTime (Date (addUTCTime (realToFrac.step $ iDoc) strt ))) (stop iDoc) ) mdbCFG
mkInsert (FDInsert iDoc mdbCFG) = let
isDate (Date l) = l
commonInsert v = insert (mCollection mdbCFG) ["pid" =: (pid.iId $ iDoc) , "val" =: v, "time" =: (isDate.sType.start $ iDoc)]
mkValue :: ValueType -> (Double -> Double)
mkValue (Constant x) = (\_ -> x)
mkValue Random = (\x -> x)
in return $ commonInsert.(mkValue.iType.iId $ iDoc)
asDate (SeedTime (Date n)) = return n
asDate _ = guard (False) >> getCurrentTime
formatIDoc ( InsertDoc {
iId = a
, step = b
, start = c
, stop = d
} ) = do
newC <- (formatSeedType.sType $ c)
newD <- (formatSeedType.sType $ d)
return $ InsertDoc a b (SeedTime newC) (SeedTime newD)
formatSeedType :: SeedType -> IO SeedType
formatSeedType Now = getCurrentTime >>= (\t-> return $ Date t)
formatSeedType (Offset a) = do
time <- getCurrentTime
return $ Date $ addUTCTime (realToFrac a) time
formatSeedType x = return x
returnValidData :: InsertDoc -> IO InsertDoc
returnValidData doc = (guard (step doc >= 15.0)) >> validateStartStop (start doc) (stop doc) >> return doc
validateStartStop :: SeedTime -> SeedTime -> IO ()
validateStartStop strt stp = guard (stp /= strt) >> guard ( sType stp /= Now ) >>
invalidStartStop (sType strt) (sType stp)
invalidStartStop :: SeedType -> SeedType -> IO ()
invalidStartStop (Date strtDate) (Date stpDate) = do
guard (strtDate < stpDate)
invalidStartStop (Now) (Date stpDate) = do
time <- getCurrentTime
guard (time < stpDate)
invalidStartStop (Offset strt ) (Offset stp) = guard (strt < stp)
invalidStartStop _ _ = return ()
makeValidInsert doc = undefined
data InsertId = InsertId {
pid :: Int
,iType :: ValueType
}
deriving (Generic,Show,Eq)
instance ToJSON InsertId
instance FromJSON InsertId
data ValueType = Constant !Double | Random
deriving (Generic,Show,Eq)
instance ToJSON ValueType
instance FromJSON ValueType
type Seconds = Double
data SeedTime = SeedTime {
sType :: SeedType
}
deriving (Generic,Show,Ord,Eq)
instance ToJSON SeedTime
instance FromJSON SeedTime
data SeedType = Now | Date !UTCTime| Offset !Double
deriving (Generic,Show,Eq,Ord)
instance ToJSON SeedType
instance FromJSON SeedType
data InsertDoc =InsertDoc {
iId :: InsertId
,step :: Seconds
,start :: SeedTime
,stop :: SeedTime
}
deriving (Generic,Show,Eq)
instance ToJSON InsertDoc
instance FromJSON InsertDoc
