module Laborantin.Implementation (
EnvIO, runEnvIO
, defaultBackend
, defaultResult
, defaultLog
) where
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as C
import Laborantin.Types
import Laborantin.Query
import Data.Aeson (decode,encode,FromJSON,parseJSON,(.:),ToJSON,toJSON,(.=),object)
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import Control.Monad.State
import Control.Monad.Error
import Control.Applicative ((<$>),(<*>))
import Data.List
import Data.Maybe
import Data.UUID
import System.Directory
import System.Random
import System.Log.Logger
import System.Log.Handler (close)
import System.Log.Handler.Simple
import System.Log.Handler.Log4jXML
import System.Time (ClockTime(TOD),getClockTime)
type EnvIO = (StateT DynEnv IO)
runEnvIO :: EnvIO a -> IO (a,DynEnv)
runEnvIO m = runStateT m M.empty
instance ToJSON ParameterValue where
toJSON (StringParam str) = object ["type" .= ("string"::Text), "val" .= str]
toJSON (NumberParam n) = object ["type" .= ("num"::T.Text), "val" .= n]
toJSON (Array xs) = toJSON xs
toJSON (Range _ _ _) = error "should not have to encode ranges but concrete values instead"
instance ToJSON ExecutionStatus where
toJSON = toJSON . show
instance ToJSON ClockTime where
toJSON (TOD secs ps) = object [ "sec" .= secs
, "ps" .= ps
, "zero" .= ("epoch" :: String)
]
instance ToJSON (Execution a) where
toJSON (Exec sc params path status es tsts) = object [ "scenario-name" .= sName sc
, "params" .= params
, "path" .= path
, "status" .= status
, "ancestors" .= (map toJSON es)
, "timestamps" .= tsts
]
where ancestors = map f es
f x = toJSON (ePath x, sName $ eScenario x)
instance FromJSON ParameterValue where
parseJSON (A.Object v) = (v .: "type") >>= match
where match :: T.Text -> A.Parser ParameterValue
match "string" = StringParam <$> v .: "val"
match "num" = NumberParam <$> v .: "val"
match "range" = error "should not have to read ranges"
match _ = mzero
parseJSON _ = mzero
instance FromJSON ExecutionStatus where
parseJSON (A.String txt) = return $ read $ T.unpack txt
parseJSON _ = mzero
instance FromJSON ClockTime where
parseJSON (A.Object v) = TOD <$> v .: "sec" <*> v .: "ps"
parseJSON _ = mzero
instance FromJSON StoredExecution where
parseJSON (A.Object v) = Stored <$>
v .: "params" <*>
v .: "path" <*>
v .: "status" <*>
v .: "ancestors" <*>
v .: "timestamps"
parseJSON _ = mzero
defaultBackend :: Backend EnvIO
defaultBackend = Backend "default EnvIO backend" prepare finalize setup run teardown analyze recover result load log rm
where prepare :: ScenarioDescription EnvIO -> ParameterSet -> EnvIO (Execution EnvIO,Finalizer EnvIO)
prepare = prepareNewScenario
finalize exec finalizer = do
finalizer exec
now <- liftIO $ getClockTime
let exec' = updateCompletionTime exec now
liftIO . putStrLn $ "execution finished\n"
liftIO $ BSL.writeFile (rundir ++ "/execution.json") (encode exec')
where rundir = ePath exec
setup = callHooks "setup" . eScenario
run = callHooks "run" . eScenario
teardown = callHooks "teardown" . eScenario
analyze exec = liftIO (T.putStrLn $ advertise exec) >> callHooks "analyze" (eScenario exec)
recover err exec = unAction (doRecover err)
where doRecover = fromMaybe (\_ -> Action $ return ()) (sRecoveryAction $ eScenario exec)
result exec = return . defaultResult exec
log exec = return $ defaultLog exec
rm exec = liftIO $ removeDirectoryRecursive $ ePath exec
callHooks key sc = maybe (error $ "no such hook: " ++ T.unpack key) unAction (M.lookup key $ sHooks sc)
load = loadExisting
updateCompletionTime :: Execution m -> ClockTime -> Execution m
updateCompletionTime exec t1 = exec {eTimeStamps = (t0,t1)}
where t0 = fst $ eTimeStamps exec
advertise :: Execution m -> Text
advertise exec = T.pack $ unlines [ "scenario: " ++ (show . sName . eScenario) exec
, "rundir: " ++ ePath exec
, "json-params: " ++ (C.unpack . encode . eParamSet) exec
]
prepareNewScenario :: ScenarioDescription EnvIO -> ParameterSet -> EnvIO (Execution EnvIO,Finalizer EnvIO)
prepareNewScenario sc params = do
(now,uuid) <- liftIO $ do
now <- getClockTime
id <- randomIO :: IO UUID
return (now,id)
let rundir = intercalate "/" [T.unpack (sName sc), show uuid]
let exec = Exec sc params rundir Running [] (now,now)
liftIO $ print "resolving dependencies"
resolveDependencies exec
handles <- liftIO $ do
createDirectoryIfMissing True rundir
BSL.writeFile (rundir ++ "/execution.json") (encode exec)
updateGlobalLogger (loggerName exec) (setLevel DEBUG)
h1 <- fileHandler (rundir ++ "/execution-log.txt") DEBUG
h2 <- log4jFileHandler (rundir ++ "/execution-log.xml") DEBUG
forM_ [h1,h2] (updateGlobalLogger (loggerName exec) . addHandler)
T.putStrLn $ advertise exec
return [h1,h2]
return (exec, \_ -> liftIO $ forM_ handles close)
resolveDependencies :: Execution EnvIO -> EnvIO ()
resolveDependencies exec = do
pending <- getPendingDeps exec (sDeps $ eScenario exec)
resolveDependencies' exec [] pending
resolveDependencies' :: Execution EnvIO -> [Dependency EnvIO] -> [Dependency EnvIO] -> EnvIO ()
resolveDependencies' exec _ [] = return ()
resolveDependencies' exec attempted trying
| all (\d -> elem d attempted) trying = error "cannot solve dependencies"
| otherwise = do
mapM (flip dSolve exec) trying
pending <- getPendingDeps exec trying
resolveDependencies' exec (trying ++ attempted) pending
getPendingDeps exec deps = map fst . filter (not . snd). zip deps <$> mapM (flip dCheck exec) deps
loadExisting :: [ScenarioDescription EnvIO] -> TExpr Bool -> EnvIO [Execution EnvIO]
loadExisting scs qexpr = do
concat <$> mapM f scs
where f :: ScenarioDescription EnvIO -> EnvIO [Execution EnvIO]
f sc = do
paths <- map ((name ++ "/") ++) . filter notDot <$> liftIO (getDirectoryContents name)
allExecs <- mapM (loadOne sc scs) paths
return $ filter (matchTExpr qexpr) allExecs
where notDot dirname = take 1 dirname /= "."
name = T.unpack $ sName sc
loadOne :: ScenarioDescription EnvIO -> [ScenarioDescription EnvIO] -> FilePath -> EnvIO (Execution EnvIO)
loadOne sc scs path = do
stored <- decode <$> liftIO (BSL.readFile (path ++ "/execution.json"))
maybe (error $ "decoding: " ++ path) forStored stored
where forStored (Stored params path status pairs tsts) = do
ancestors <- loadAncestors scs pairs
return $ Exec sc params path status ancestors tsts
loadAncestors :: [ScenarioDescription EnvIO] -> [(FilePath,Text)] -> EnvIO [Execution EnvIO]
loadAncestors scs pairs = catMaybes <$> mapM loadFromPathAndName pairs
where loadFromPathAndName :: (FilePath,Text) -> EnvIO (Maybe (Execution EnvIO))
loadFromPathAndName (path, name) = do
let sc = find ((== name) . sName) scs
maybe (return Nothing) (\x -> Just <$> loadOne x scs path) sc
defaultResult :: Execution m -> FilePath -> Result EnvIO
defaultResult exec basename = Result path read append write
where read = liftIO $ T.readFile path
append dat = liftIO $ T.appendFile path dat
write dat = liftIO $ T.writeFile path dat
path = intercalate "/" [ePath exec, basename]
defaultLog :: Execution m -> LogHandler EnvIO
defaultLog exec = LogHandler logF
where logF txt = liftIO $ debugM (loggerName exec) (T.unpack txt)
path = ePath exec ++ "/execution.log"
loggerName :: Execution m -> String
loggerName exec = "laborantin:" ++ ePath exec