[Initial record of snap site. Vladimir Still **20130219125124 Ignore-this: b23e9d0967d7ac1b86062c953c99e7fa ] addfile ./.ghci hunk ./.ghci 1 +:set -isrc +:set -hide-package MonadCatchIO-mtl +:set -hide-package monads-fd +:set -XOverloadedStrings addfile ./public_snap.cabal hunk ./public_snap.cabal 1 +Name: publicsnap +Version: 0.1 +Synopsis: Project Synopsis Here +Description: Project Description Here +License: BSD3 +Author: Author +Maintainer: maintainer@example.com +Stability: Experimental +Category: Web +Build-type: Simple +Cabal-version: >=1.2 + +Flag development + Description: Whether to build the server in development (interpreted) mode + Default: True + +Executable publicsnap + hs-source-dirs: src + main-is: Main.hs + + Build-depends: + base >= 4 && < 5, + bytestring >= 0.9.1 && < 0.11, + data-lens >= 2.0.1 && < 2.11, + data-lens-template >= 2.1 && < 2.2, + heist >= 0.8 && < 0.9, + MonadCatchIO-transformers >= 0.2.1 && < 0.4, + mtl >= 2 && < 3, + snap == 0.9.*, + snap-core >= 0.9.2 && <0.10, + snap-server >= 0.9.2 && <0.10, + snap-loader-static == 0.9.*, + text >= 0.11 && < 0.12, + time >= 1.1 && < 1.5, + xmlhtml >= 0.1, + array >= 0.4, + containers >= 0.4, + deepseq >= 1.3, + directory >= 1.1, + transformers >= 0.3, + filepath >= 1.3, + old-locale >= 1.0.0.4, + process >= 1.1.0.1, + conduit >= 0.5.4.1, + pool-conduit >= 0.1.0.3, + persistent >= 1.0.1.3, + resourcet >= 0.4.3, + monad-logger >= 0.2.1, + persistent-template >= 1.0.0.2, + persistent-postgresql >= 1.0.0, + hex >= 0.1.2 + + + if flag(development) + build-depends: + snap-loader-dynamic == 0.9.* + cpp-options: -DDEVELOPMENT + -- In development mode, speed is already going to suffer, so skip + -- the fancy optimization flags. Additionally, disable all + -- warnings. The hint library doesn't give an option to execute + -- compiled code when there were also warnings, so disabling + -- warnings allows quicker workflow. + ghc-options: -threaded -w + else + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-orphans -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-orphans adddir ./snaplets adddir ./snaplets/heist adddir ./snaplets/heist/templates addfile ./snaplets/heist/templates/base.tpl hunk ./snaplets/heist/templates/base.tpl 1 + + + + + <title_content/> + + + + + + addfile ./snaplets/heist/templates/result.tpl hunk ./snaplets/heist/templates/result.tpl 1 + + Index page + + + + + + +

Result

+

Configuration

+ +

Model

+ +

Version

+ + +

Wall Time

+ +

System Time

+ +

Memory Used

+ + +

RAW

+ + + addfile ./snaplets/heist/templates/select.tpl hunk ./snaplets/heist/templates/select.tpl 1 + + Result selection + + + +

Select results

+
+

Configuration

+ + +

+ +

+
+ + addfile ./snaplets/heist/templates/select_model.tpl hunk ./snaplets/heist/templates/select_model.tpl 1 + + Result selection + + + +

Select results

+
+

Model

+ + +

Statistic

+ + + + +

+ +

+ +
+ addfile ./snaplets/heist/templates/select_version.tpl hunk ./snaplets/heist/templates/select_version.tpl 1 + + Result selection + + + +

Select results

+
+

Divine Version

+ + + + +

+ +

+ +
+ adddir ./src addfile ./src/Application.hs hunk ./src/Application.hs 1 +{-# LANGUAGE TemplateHaskell #-} + +------------------------------------------------------------------------------ +-- | This module defines our application's state type and an alias for its +-- handler monad. +module Application where + +------------------------------------------------------------------------------ +import Data.Lens.Template +import Snap.Snaplet +import Snap.Snaplet.Heist +import Snap.Snaplet.Auth +import Snap.Snaplet.Session + +------------------------------------------------------------------------------ +data App = App + { _heist :: Snaplet (Heist App) + } + +-- some template magic +makeLens ''App + +instance HasHeist App where + heistLens = subSnaplet heist + + +------------------------------------------------------------------------------ +type AppHandler = Handler App App + + adddir ./src/DB addfile ./src/DB/.ghci hunk ./src/DB/.ghci 1 +:set -i.. +:set -XOverloadedStrings addfile ./src/DB/Benchmark.hs hunk ./src/DB/Benchmark.hs 1 +{-# LANGUAGE TypeFamilies + , MultiParamTypeClasses + , FlexibleInstances + , QuasiQuotes + , GeneralizedNewtypeDeriving + , TemplateHaskell + , OverloadedStrings + , GADTs + , FlexibleContexts + , StandaloneDeriving + , NamedFieldPuns #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module DB.Benchmark where + +import DivineCommon + +import Prelude hiding (readList) + +import Control.Monad +import Control.Applicative +import Control.Monad.Trans.Error +import Control.Monad.IO.Class +import Control.Exception (catch) +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Trans.Resource (MonadUnsafeIO, MonadThrow, MonadBaseControl, MonadResource, runResourceT) + +import Data.List (intercalate) +import Data.Maybe +import Data.List (sort) +import Data.ByteString (ByteString) +import Data.Ix (Ix) +import Data.Time.Clock (UTCTime) + +import Database.Persist +import Database.Persist.Store +import Database.Persist.GenericSql +import Database.Persist.Postgresql +import Database.Persist.TH + +import System.Directory + +import Data.Int +import Data.List (intercalate) +import Data.Hex (hex) +import Data.Conduit.Pool (Pool) +import Data.ByteString.Char8 (unpack) + +derivePersistField "Algorithm" +derivePersistField "Flag" +derivePersistField "PropertyType" +derivePersistField "Transformation" +derivePersistField "CompileFlag" + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +Config + algorithm Algorithm + compileFlags [CompileFlag] default='[]' + flags [Flag] + architecture String + UqConfiguration algorithm flags architecture + +Model + label String + hasProperty Bool + UqModel label + +MpiVersion + major Int32 + minor Int32 + build Int32 + implementation String + UqMpiVersion major minor build implementation + +DivineVersion + major Int32 + minor Int32 + build Int32 + hash ByteString + pointerWidth Int32 + debug Bool + buildDate UTCTime + mpiVersion MpiVersionId + UqDivineVersion major minor build hash pointerWidth debug buildDate mpiVersion + +Benchmark + config ConfigId + model ModelId + divineVersion DivineVersionId + threads Int32 + mpiNodes Int32 + propertyType PropertyType Maybe + transformations [Transformation] + propertyHolds Bool Maybe + fullStateSpace Bool Maybe + statesVisited Int64 + statesAccepting Int64 + statesExpanded Int64 + transitionCount Int64 Maybe + deadlockCount Int64 Maybe + memoryUsed Int64 + userTime Double + systemTime Double + wallTime Double + terminationSignal Int32 Maybe + finished Bool + executionCommand String Maybe + testId String + UqTestId testId +|] + +deriving instance Show (ConfigGeneric a) +deriving instance Read (ConfigGeneric a) + +deriving instance Show (ModelGeneric a) +deriving instance Read (ModelGeneric a) + +deriving instance Show (MpiVersionGeneric a) +deriving instance Read (MpiVersionGeneric a) + +deriving instance Show (DivineVersionGeneric a) +deriving instance Read (DivineVersionGeneric a) + +deriving instance Show (BenchmarkGeneric a) +deriving instance Read (BenchmarkGeneric a) + +toBenchmarkKey :: Int64 -> Key SqlPersist Benchmark +toBenchmarkKey x = Key (PersistInt64 x) + +toConfigKey :: Int64 -> Key SqlPersist Config +toConfigKey x = Key (PersistInt64 x) + +toModelKey :: Int64 -> Key SqlPersist Model +toModelKey x = Key (PersistInt64 x) + +toDivineVersionKey :: Int64 -> Key SqlPersist DivineVersion +toDivineVersionKey x = Key (PersistInt64 x) + +toMpiVersionKey :: Int64 -> Key SqlPersist MpiVersion +toMpiVersionKey x = Key (PersistInt64 x) + +getFromPool :: (PersistEntity val) => Key SqlPersist val -> Pool Connection -> IO (Maybe val) +getFromPool id = runSqlPool $ get id + +getAll :: (PersistEntity val, PersistEntityBackend val ~ SqlPersist) => Pool Connection -> IO [Entity val] +getAll = runSqlPool $ selectList [] [] + +class LookupShow a where + lookupShow :: a -> [(String, String)] + +instance LookupShow Config where + lookupShow (Config { configAlgorithm + , configCompileFlags + , configFlags + , configArchitecture + }) = [ ("Algorithm", show configAlgorithm) + , ("Compile-Flags", show configCompileFlags) + , ("Flags", show configFlags) + , ("Architecture", configArchitecture) + ] + +instance LookupShow Model where + lookupShow (Model { modelLabel + , modelHasProperty + }) = [ ("Name", modelLabel) + , ("Has Property", show modelHasProperty) + ] + +instance LookupShow DivineVersion where + lookupShow (DivineVersion { divineVersionMajor + , divineVersionMinor + , divineVersionBuild + , divineVersionHash + , divineVersionPointerWidth + , divineVersionDebug + , divineVersionBuildDate + }) = [ ("Version", intercalate "." (map show [ divineVersionMajor + , divineVersionMinor + , divineVersionBuild + ]) ++ "+" ++ unpack + (hex divineVersionHash)) + , ("Pointer Width", show divineVersionPointerWidth) + , ("Debug", show divineVersionDebug) + , ("Build Date", show divineVersionBuildDate) + ] + + +instance LookupShow MpiVersion where + lookupShow (MpiVersion { mpiVersionMajor + , mpiVersionMinor + , mpiVersionBuild + , mpiVersionImplementation + }) + = [ ("MPI Version", intercalate "." (map show [ mpiVersionMajor + , mpiVersionMinor + , mpiVersionBuild + ]) ++ " " ++ + mpiVersionImplementation + )] + +prettyShow :: LookupShow a => a -> String +prettyShow = intercalate ", " . map (\(x,y) -> x ++ ": " ++ y) . lookupShow + +prettyShow' :: LookupShow a => a -> String +prettyShow' = intercalate ", " . map snd . lookupShow + +k2I64 :: PersistEntity val => Key SqlPersist val -> Int64 +k2I64 (Key (PersistInt64 k)) = k adddir ./src/DataTable addfile ./src/DataTable.hs hunk ./src/DataTable.hs 1 - +{-# LANGUAGE TypeFamilies + , TupleSections #-} +module DataTable where + +import Indexable +import Control.Monad +import Data.Array (Array) + +newtype DataTable i j e = DT { unDT :: Array (i,j) e } + +instance (Ix i, Ix j) => Functor (DataTable i j) where + fmap f = DT . fmap f . unDT + +instance (Ix i, Ix j) => Indexable (DataTable i j) where + type Index (DataTable i j) = (i, j) + + (!) = (!) . unDT + assocs = assocs . unDT + elems = elems . unDT + +instance (Ix i, Ix j) => BoundedIndexable (DataTable i j) where + bounds = bounds . unDT + indices = indices . unDT + +data ColView i j e = CV (j -> e) (j, j) +data RowView i j e = RV (i -> e) (i, i) + +instance (Ix i, Ix j) => Indexable (ColView i j) where + type Index (ColView i j) = j + + (CV ix _) ! y = ix y + assocs (CV ix b) = [ (y, ix y) | y<-range b ] + +instance (Ix i, Ix j) => Indexable (RowView i j) where + type Index (RowView i j) = i + + (RV iy _) ! x = iy x + assocs (RV iy b) = [ (x, iy x) | x<-range b ] + +instance (Ix i, Ix j) => BoundedIndexable (ColView i j) where + bounds (CV _ b) = b + +instance (Ix i, Ix j) => BoundedIndexable (RowView i j) where + bounds (RV _ b) = b + +(!|) :: (BoundedIndexable f, Index f ~ (i, j)) => f e -> i -> ColView i j e +table !| x = CV ix bb + where + bb = sel (bounds table) + sel ((_, y1), (_, y2)) = (y1, y2) + ix y = table ! (x, y) + +(!-) :: (BoundedIndexable f, Index f ~ (i,j)) => f e -> j -> RowView i j e +table !- y = RV ix bb + where + bb = sel (bounds table) + sel ((x1, _), (x2, _)) = (x1, x2) + ix x = table ! (x, y) + +colBounds :: (Ix i, Ix j) => DataTable i j e -> (j, j) +colBounds = (\((_, y1), (_, y2)) -> (y1, y2)) . bounds + +rowBounds :: (Ix i, Ix j) => DataTable i j e -> (i, i) +rowBounds = (\((x1, _), (x2, _)) -> (x1, x2)) . bounds addfile ./src/DataTable/.ghci hunk ./src/DataTable/.ghci 1 - +:set -i.. addfile ./src/DataTable/IO.hs hunk ./src/DataTable/IO.hs 1 +{-# LANGUAGE TupleSections #-} +module DataTable.IO (loadFromFiles, trToDataTable) where + +import DataTable +import DB.TestResult +import DivineCommon + +import Data.Ix (Ix) +import Data.List (foldl1') +import Data.Maybe (mapMaybe) +import Data.Array.MArray.Safe (newArray, readArray, writeArray) +import Data.Array.ST.Safe (runSTArray) + +import Control.Monad ((>=>)) +import Control.DeepSeq (NFData, ($!!)) + +(>>=!) :: (Monad m, NFData a) => m a -> (a -> m b) -> m b +infixl 1 >>=! +a >>=! f = a >>= (return $!!) >>= f + +loadFromFiles + :: (Ix i, Ix j) + => (FilePath -> String -> Maybe (i,j,e)) + -> [FilePath] + -> IO (Maybe (DataTable i j [e])) +loadFromFiles sel = mapM (\f -> readFile f >>=! return . (f,)) >=> + return . makeTable (uncurry sel) + +makeTable :: (Ix i, Ix j) => (a -> Maybe (i,j,e)) -> [a] -> Maybe (DataTable i j [e]) +makeTable sel contents = case values of + [] -> Nothing + _ -> Just (DT array) + where + values = mapMaybe sel contents + bounds = g (foldl1' mm (map f values)) + f (i,j,_) = (i,i, j,j) + g (imi, ima, jmi, jma) = ((imi, jmi), (ima, jma)) + mm (imi, ima, jmi, jma) (i,_, j, _) = (imi `min` i, ima `max` i, + jmi `min` j, jma `max` j) + array = runSTArray $ + newArray bounds [] >>= \arr -> + mapM_ (\(i,j,e) -> modify arr (i,j) e) values >> + return arr + modify arr (i,j) e = readArray arr (i,j) >>= writeArray arr (i,j) . (e:) + +trToDataTable + :: (Ix j, Ix i) + => (TestResult -> i) + -> (TestResult -> j) + -> [TestResult] + -> Maybe (DataTable i j [TestResult]) +trToDataTable x y = makeTable sel + where + sel tr = Just (x tr, y tr, tr) addfile ./src/DataTable/Output.hs hunk ./src/DataTable/Output.hs 1 +{-# LANGUAGE OverloadedStrings #-} +module DataTable.Output + ( toHtmlGeneric + , toHtml + , toHtmlWDefault + , toHtmlWEmptyDefault + , toJsArray + ) where + +import DataTable +import Indexable + +import Text.XmlHtml +import Data.Ix (Ix) +import Data.Text (Text, pack, empty) +import Data.List (intercalate) + +showT :: Show a => a -> Text +showT = pack . show + +toHtmlGeneric :: (Ix i, Ix j) => (i -> Text) -> (j -> Text) -> (e -> Text) -> DataTable i j e -> Node +toHtmlGeneric si sj se dt = Element "table" [] (fline : rows) + where + fline = tr' (tdText empty : map (tdText . si) rowR) + rows = map (tr' . row) colR + row j = tdText (sj j) : [ tdText (se (dt ! (i,j))) | i<-rowR ] + + rowR = range (rowBounds dt) + colR = range (colBounds dt) + +toHtml :: (Ix i, Ix j, Show i, Show j, Show e) => DataTable i j e -> Node +toHtml = toHtmlGeneric showT showT showT + +toHtmlWDefault :: (Ix i, Ix j, Show i, Show j, Show e) => Text -> DataTable i j (Maybe e) -> Node +toHtmlWDefault def = toHtmlGeneric showT showT showWD + where + showWD Nothing = def + showWD (Just x) = showT x + +toHtmlWEmptyDefault :: (Ix i, Ix j, Show i, Show j, Show e) => DataTable i j (Maybe e) -> Node +toHtmlWEmptyDefault = toHtmlWDefault empty + + + +table :: [(Text, Text)] -> [Node] -> Node +table = Element "table" + +table' :: [Node] -> Node +table' = table [] + +tr :: [(Text, Text)] -> [Node] -> Node +tr = Element "tr" + +tr' :: [Node] -> Node +tr' = tr [] + +td :: [(Text, Text)] -> [Node] -> Node +td = Element "td" + +td' :: [Node] -> Node +td' = td [] + +tdText :: Text -> Node +tdText = td' . (:[]) . TextNode + +toJsArray :: (Ix i, Ix j) => (i -> String) -> (j -> String) -> (e -> String) -> DataTable i j e -> String +toJsArray si sj se dt = arr (fline : rows) + where + fline = "\'t\'" : map si rowR + rows = map row colR + row j = sj j : [ se (dt ! (i,j)) | i<-rowR ] + + rowR = range (rowBounds dt) + colR = range (colBounds dt) + + arr xs = "[ " ++ intercalate ", " (map inArr xs) ++ " ]" + inArr xs = "[ " ++ intercalate ", " xs ++ " ]\n" addfile ./src/DataTable/Statistics.hs hunk ./src/DataTable/Statistics.hs 1 - +module DataTable.Statistics where + +import Indexable +import DataTable +import Data.Ix (Ix) +import Control.Monad (liftM2) + +data Statistics = Average | Minimum | Maximum | Median + deriving (Eq, Ix, Show, Read, Ord) + +applyStat :: (Ix i, Ix j, Ord e, Fractional e) => Statistics -> DataTable i j [e] -> DataTable i j (Maybe e) +applyStat st = case st of + Average -> dtAverage + Minimum -> dtMinimum + Maximum -> dtMaximum + Median -> dtMedian + +safe :: ([e] -> e) -> [e] -> Maybe e +safe f [] = Nothing +safe f xs = Just (f xs) + +dtAverage :: (Ix i, Ix j, Fractional e) => DataTable i j [e] -> DataTable i j (Maybe e) +dtAverage = fmap (safe (\x -> sum x / fromIntegral (length x))) + +dtMinimum :: (Ix i, Ix j, Ord e) => DataTable i j [e] -> DataTable i j (Maybe e) +dtMinimum = fmap (safe minimum) + +dtMaximum :: (Ix i, Ix j, Ord e) => DataTable i j [e] -> DataTable i j (Maybe e) +dtMaximum = fmap (safe maximum) + +dtMedian :: (Ix i, Ix j, Fractional e) => DataTable i j [e] -> DataTable i j (Maybe e) +dtMedian = fmap (safe med) + where + med [x] = x + med [x,y] = (x + y) / 2 + med xs = med (tail (init xs)) + +data Transform i j = Scalability i j + | Identity + deriving (Eq, Show, Read) + +applyTransform :: (Ix i, Ix j, Fractional e) => Transform i j -> DataTable i j (Maybe e) -> DataTable i j (Maybe e) +applyTransform tr = case tr of + Scalability i j -> scalability i j + Identity -> id + +scalability :: (Ix i, Ix j, Fractional e) => i -> j -> DataTable i j (Maybe e) -> DataTable i j (Maybe e) +scalability i j dt = fmap transform dt + where + ref = dt ! (i,j) + transform val = liftM2 (/) val ref addfile ./src/DivineCommon.hs hunk ./src/DivineCommon.hs 1 +{-# LANGUAGE NamedFieldPuns #-} +module DivineCommon where + +import Data.Char +import System.Process (CmdSpec (RawCommand)) +import Data.Ix (Ix) +import Text.Read +import Text.ParserCombinators.ReadP as P + +if' :: Bool -> a -> a -> a +if' True t _ = t +if' False _ f = f + +data Algorithm = Reachability | NestedDFS | OWCTY | MAP + deriving (Eq, Ord, Show, Read, Enum, Ix) + +data CompileFlag = POSIX | O_PERFORMANCE | O_DVE | O_LEGACY + | O_HASH_COMPACTION | O_POOLS | O_CURSES + | O_TIMED | O_LLVM | O_LTL3BA | O_SMALL + | O_MPIDEBUG | O_USE_GCC_M64 | O_USE_GCC_M32 + | O_COIN | O_MPI | O_LTL2DSTAR | O_MURPHI + deriving (Eq, Ord, Show, Read) + +data Flag = PrintInfo + | Threads Int + | NoCEGeneration + deriving (Eq, Ord, Show, Read) + +data PropertyType = Neverclaim + deriving (Show, Read, Eq, Ord) + +data Transformation = None | POR | Huffman | TauPlus | Heap + deriving (Show, Read, Eq, Ord) + +data DivineStartInfo = DSI { dsiExecPath :: FilePath + , dsiAlgorithm :: Algorithm + , dsiModel :: FilePath + , dsiParams :: [Flag] + } deriving (Eq, Show) + +startInfoToCommand :: DivineStartInfo -> CmdSpec +startInfoToCommand (DSI { dsiExecPath, dsiAlgorithm, dsiModel, dsiParams }) + = RawCommand dsiExecPath $ (makeAlgorithm dsiAlgorithm) : dsiModel : makeParams dsiParams + +makeAlgorithm :: Algorithm -> String +makeAlgorithm alg = case alg of + NestedDFS -> "nested-dfs" + x -> map toLower $ show x + +makeParams :: [Flag] -> [String] +makeParams = foldr makeParam [] + +makeParam :: Flag -> [String] -> [String] +makeParam param = case param of + PrintInfo -> ("-r" :) + Threads n -> ("-w" :) . (show n :) + NoCEGeneration -> ("-n" :) + +{- TAKEN FROM NEW VESION OB BASE -} + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- A 'Left' value indicates a parse error. +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = do + x <- readPrec + lift P.skipSpaces + return x + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a addfile ./src/Indexable.hs hunk ./src/Indexable.hs 1 - +{-# LANGUAGE FlexibleContexts + , TypeFamilies #-} +module Indexable + ( module Data.Ix + , Indexable ((!), elems, assocs) + , Index + , BoundedIndexable (bounds, indices) + ) where + +import Data.Ix +import Data.Array hiding ((!), elems, assocs, bounds, indices) +import qualified Data.Array as Ar ((!), elems, assocs, bounds, indices) + +class Indexable f where + type Index f :: * + + (!) :: f e -> Index f -> e + elems :: f e -> [e] + assocs :: f e -> [(Index f, e)] + + elems = map snd . assocs + +class (Indexable f, Ix (Index f)) => BoundedIndexable f where + bounds :: f e -> (Index f, Index f) + indices :: f e -> [Index f] + + indices = range . bounds + +instance Ix i => Indexable (Array i) where + type Index (Array i) = i + + (!) = (Ar.!) + assocs = Ar.assocs + elems = Ar.elems + +instance Ix i => BoundedIndexable (Array i)where + bounds = Ar.bounds + indices = Ar.indices + +instance Indexable [] where + type Index [] = Int + + (!) = (!!) + assocs = zip [0..] + elems = id + + addfile ./src/Site.hs hunk ./src/Site.hs 1 +{-# LANGUAGE OverloadedStrings + , TypeFamilies + , ScopedTypeVariables #-} +-- overloaded strings are used for infering type of +-- string literal from context, it can be for example one of +-- String == [Char] +-- ByteString (Data.Bytestring) +-- Text (Data.Text) + +------------------------------------------------------------------------------ +-- | This module is where all the routes and handlers are defined for your +-- site. The 'app' function is the initializer that combines everything +-- together and is exported by this module. +module Site + ( app + ) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe +import Control.DeepSeq + +import Data.List +import Data.Int +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS (unpack, pack) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text, append) +import qualified Data.Text as T +import Data.Text.Encoding as T +import Data.Char +import Data.Conduit.Pool (Pool) +import Data.Map ( fromList, (!), assocs ) + +import qualified Text.XmlHtml as X +import Text.Templating.Heist +import Text.Printf + +import System.Directory +import System.FilePath + +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Auth +import Snap.Snaplet.Auth.Backends.JsonFile +import Snap.Snaplet.Heist +import Snap.Snaplet.Session.Backends.CookieSession +import Snap.Util.FileServe +import Snap.Http.Server (snapServerVersion) +------------------------------------------------------------------------------ +import Application + +import Database.Persist.Postgresql + +import DataTable +import DataTable.IO +import DataTable.Output +import DataTable.Statistics +import DivineOutParser +import DivineCommon +import DB.Benchmark +import DB.TestResult + +------------------------------------------------------------------------------ +-- | The application's routes. +routes :: [(ByteString, Handler App App ())] +routes = [ ("/", heistServe) +-- , ("/some/other/path", someHandler) + ] + +splices :: [(T.Text, SnapletSplice App App)] +splices = [ ("info", serverInfo) + , ("data_table", dataTable2Html) + , ("test_config", testConfig) + , ("test_model", testModel) + , ("test_divine_version", testDivineVersion) + , ("test_result_table", testResultTable) + , ("test_options", testOptions) + , ( "form_forward_params", formForwardParams ) + ] + +serverInfo :: SnapletSplice App App +serverInfo = return [ X.Element "p" [] + [ X.TextNode ( "Powered by snap framework " `append` serverVersion ) ] ] + +fromMaybeT :: Monad m => a -> MaybeT m a -> m a +fromMaybeT def mx = do + x <- runMaybeT mx + case x of + Just a -> return a + Nothing -> return def + +liftMaybe :: Monad m => Maybe a -> MaybeT m a +liftMaybe = MaybeT . return + + +formForwardParams :: SnapletSplice App App +formForwardParams = liftHeist $ fromMaybeT [ X.Comment "Error forwarding get" ] $ + lift getRequest >>= return . concatMap toHidden . assocs . rqParams + where + toHidden :: ( ByteString, [ ByteString ] ) -> [ X.Node ] + toHidden ( key, vals ) = map ( \val -> X.Element "input" + [ ( "type", "hidden" ), ( "name", T.decodeUtf8 key ), ( "value", T.decodeUtf8 val ) ] [] ) + vals + + + + +testOptions :: SnapletSplice App App +testOptions = liftHeist $ fromMaybeT [X.TextNode "Error occureed while loading, sorry"] $ do + typ <- lift getParamNode >>= liftMaybe . X.getAttribute "type" >>= return . T.unpack + case typ of + "model" -> do + req <- lift getRequest + let Just dvids = rqParam "dv" req >>= + mapM ( readMaybe . BS.unpack >=> return . toDivineVersionKey ) + Just cids = rqParam "config" req >>= + mapM ( readMaybe . BS.unpack >=> return . toConfigKey ) + ms <- liftIO . withPgsql . runSqlPool $ do + bs <- selectList [ BenchmarkConfig <-. cids, BenchmarkDivineVersion <-. dvids ] [] + let mids = nub . sort . map ( benchmarkModel . entityVal ) $ bs + selectList [ ModelId <-. mids ] [] + return $ map models ms + "dv" -> do + req <- lift getRequest + let Just cids = rqParam "config" req >>= + mapM ( readMaybe . BS.unpack >=> return . toConfigKey ) + dvs <- liftIO . withPgsql . runSqlPool $ do + bs <- selectList [ BenchmarkConfig <-. cids ] [] + let vids = nub . sort .map ( benchmarkDivineVersion . entityVal ) $ bs + selectList [ DivineVersionId <-. vids ] [] + return $ map divinevs dvs + "config" -> put configs + x -> return [X.TextNode $ "Invalid option " `append` (T.pack x) ] + + where + get :: (PersistEntityBackend val ~ SqlPersist, PersistEntity val) + => MaybeT (HeistT (Handler App App)) [ Entity val ] + get = liftIO $ withPgsql $ getAll + + put :: (PersistEntityBackend val ~ SqlPersist, PersistEntity val) + => (Entity val -> X.Node) -> MaybeT (HeistT (Handler App App)) [X.Node] + put f = get >>= return . map f + + models :: Entity Model -> X.Node + models (Entity k model) = toOpt k model + + divinevs :: Entity DivineVersion -> X.Node + divinevs (Entity k dv) = toOpt k dv + + configs :: Entity Config -> X.Node + configs (Entity k cfg) = toOpt k cfg + + toOpt :: LookupShow a => PersistEntity val => Key SqlPersist val -> a -> X.Node + toOpt k x = X.Element "option" [("value", key)] [X.TextNode value] + where + value = T.pack $ prettyShow x + key = T.pack . show $ k2I64 k + + +configId :: MonadSnap m => MaybeT m [(Key SqlPersist Config)] +configId = lift getRequest >>= + liftMaybe . rqParam "config" >>= + return . mapMaybe (return . toConfigKey <=< readMaybe . BS.unpack) + +modelId :: MonadSnap m => MaybeT m (Key SqlPersist Model) +modelId = getReqKey "model" toModelKey + +divineVersionId :: MonadSnap m => MaybeT m (Key SqlPersist DivineVersion) +divineVersionId = getReqKey "dv" toDivineVersionKey + +mpiVersionId :: MonadSnap m => MaybeT m (Key SqlPersist MpiVersion) +mpiVersionId = getDivineVersion >>= return . divineVersionMpiVersion + +getConfig :: MonadSnap m => MaybeT m [Config] +getConfig = configId >>= mapM getDb + +getModel :: MonadSnap m => MaybeT m Model +getModel = modelId >>= getDb + +getDivineVersion :: MonadSnap m => MaybeT m DivineVersion +getDivineVersion = divineVersionId >>= getDb + +getMpiVersion :: MonadSnap m => MaybeT m MpiVersion +getMpiVersion = mpiVersionId >>= getDb + +testConfig :: SnapletSplice App App +testConfig = liftHeist $ fromMaybeT [] $ do + config <- getConfig + return $ intercalate [X.Element "br" [] []] $ map (makeTable . lookupShow) config + +testModel :: SnapletSplice App App +testModel = liftHeist $ fromMaybeT [] $ do + model <- getModel + return . makeTable $ lookupShow model + +testDivineVersion :: SnapletSplice App App +testDivineVersion = liftHeist $ fromMaybeT [] $ do + dv <- getDivineVersion + mv <- getMpiVersion + return . makeTable $ lookupShow dv ++ lookupShow mv + +makeTable :: [(String, String)] -> [X.Node] +makeTable xs = + [ X.Element "table" [] + [ + X.Element "tr" [] + [ X.Element "td" [] [X.TextNode key] + , X.Element "td" [] [X.TextNode value] + ] + | (k,v)<-xs, let key = T.pack k, let value = T.pack v + ] + ] + +-- showXmlM getDivineVersion + +showXml :: Show a => a -> [X.Node] +showXml x = [ X.TextNode (T.pack (show x)) ] + +showXmlM :: (Show a, Monad m) => m a-> m [X.Node] +showXmlM = liftM showXml + +getReqKey :: (MonadSnap m, PersistEntity a) => ByteString -> (Int64 -> Key SqlPersist a) -> MaybeT m (Key SqlPersist a) +getReqKey param toKey = do + req <- lift $ getRequest + MaybeT . return $ getRequestParam req param >>= readMaybe >>= return . toKey + +getDb :: (MonadSnap m, PersistEntity a) => Key SqlPersist a -> MaybeT m a +getDb key = MaybeT $ liftIO $ withPgsql $ getFromPool key + +testResultTable :: SnapletSplice App App +testResultTable = liftHeist $ fromMaybeT [X.TextNode "error"] $ do + config <- configId + configs <- liftIO $ withPgsql $ getAll + model <- modelId + dv <- divineVersionId + stat <- MaybeT . lift $ getRequest >>= + return . (readMaybe . firstUpper <=< flip getRequestParam "stat") + res <- mapM (liftIO . withPgsql . getResult stat dv model) config >>= return . concat + table <- liftMaybe $ trToDataTable (k2I64 . trConfig) trThreads res + sel <- MaybeT $ getParamNode >>= return . (Just . T.unpack <=< X.getAttribute "select") + let selected = select sel `fmap` table + xShow = sc configs + return $ [toHtmlGeneric (T.pack . xShow) st sl selected] ++ graph sel xShow selected + + where + st :: Show a => a -> Text + st = T.pack . show + + sl [x] = T.pack x + sl _ = T.empty + + sc :: [Entity Config] -> Int64 -> String + sc config = {- prettyShow' -} show . configAlgorithm . (table !) + where + table = fromList [ (k, e) | (Entity key e)<-config, let k = k2I64 key ] + + select :: String -> [TestResult] -> [String] + select sel = case sel of + "wallTime" -> map (printf "%0.3f" . trWallTime) + "systemTime" -> map (printf "%0.3f" . trSystemTime) + "memoryUsed" -> map (show . trMemoryUsed) + _ -> map show + + biSizes = ["B", "KiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB"] + showBytes :: Int64 -> String + showBytes size = convertSize 1024 biSizes (fromIntegral size) + + roundSize :: RealFrac a => a -> a + roundSize = (/ 10).fromIntegral.ceiling.(10*) + + convertSize :: Double -> [String] -> Double -> String + convertSize base units size + | null units = error "Too big file, dont't know proper unit" + | size < base = clean (printf "%.1f" $ roundSize size) ++ " " ++ head units + | otherwise = convertSize base (tail units) (size/base) + where + clean [] = [] + clean ('.':'0':[]) = [] + clean (x:s) = x:clean s + + sl' [x] = x + sl' _ = "null" + + graph id0 sx table = + [ X.Element "script" [("type", "text/javascript")] + [ (X.TextNode . script . T.pack) (toJsArray (wrap . sx) (wrap . show) sl' table) ] + , X.Element "div" [("id", id), ("style", "width: 900px; height: 500px;")] [] + ] + where + script x = "\nfunction drawVisualization" `append` id `append` "() {\n" `append` + "// Create and draw the visualization.\n" `append` + "var ac = new google.visualization.ComboChart(document.getElementById('" `append` + id `append` "'));\n" `append` + "ac.draw(google.visualization.arrayToDataTable(" `append` x `append` "), {\n" `append` +-- " title : 'Model name: tralala',\n" `append` + " vAxis: {title: \"" `append` id `append` "\"},\n" `append` + " hAxis: {title: \"Threads\"},\n" `append` + " seriesType: \"line\",\n" `append` -- \"candlesticks\", +-- " series: {0: {type: \"line\"}}\n" + " });\n}\n" `append` + "google.setOnLoadCallback(drawVisualization" `append` id `append` ");\n" + id = T.pack id0 + wrap x = '\'' : x ++ "\'" + + +withPgsql :: (Pool Connection -> IO a) -> IO a +withPgsql = withPostgresqlPool "dbname = divineperf" 1 + +getRequestParam :: Request -> ByteString -> Maybe String +getRequestParam req param = rqParam param req >>= return . BS.unpack . head + +serverVersion :: Text +serverVersion = decodeASCII snapServerVersion + +dataTable2Html :: SnapletSplice App App +dataTable2Html = liftHeist $ do + node <- getParamNode + let path = X.getAttribute "path" node >>= Just . T.unpack + tp = fromMaybe Average (X.getAttribute "type" node >>= readMaybe . T.unpack) + tr = fromMaybe Identity (X.getAttribute "transform" node >>= readMaybe . T.unpack) + makeTable path tp tr + where + makeTable Nothing _ _ = return [X.TextNode "makeTable: Nothing"] + makeTable (Just p) tp tr = do + files <- liftIO (getDirectoryContents p >>= return . map (p ) >>= filterM doesFileExist) + dataTable <- liftIO (loadFromFiles parseFile files) + let wtTable = dataTable >>= Just . fmap (mapMaybe wallTime) + return (getTable tp tr model wtTable) + + where model = takeFileName ((if last p == pathSeparator then init else id) p) ++ " " ++ show (tp, tr) + + getTable _ _ _ Nothing = [X.TextNode "getTable: Nothing"] + getTable tp tr f (Just dt) = [X.Element "h2" [] [X.TextNode (T.pack f)], toHtmlGeneric showT showT showV (applyTransform tr (applyStat tp dt))] + + showT :: Show a => a -> T.Text + showT = T.pack . show + + showV :: Maybe Double -> T.Text + showV = maybe T.empty (T.pack . printf "%.2f") + + parseFile :: FilePath -> String -> Maybe (Int32, Algorithm, DivineOutputMap) + parseFile _ contents = do -- Maybe monad + let map = parseOutput contents + t <- threads map + a <- algorithm map + return (t, a, map) + + + +------------------------------------------------------------------------------ +-- | The application initializer. +app :: SnapletInit App App +app = makeSnaplet "app" "An snaplet example application." Nothing $ do + h <- nestSnaplet "divine" heist $ heistInit "templates" + addRoutes routes + addSplices splices + return $ App { _heist = h } +