add tests
This commit is contained in:
parent
f3a473d83e
commit
c05a3c55ef
@ -8,12 +8,17 @@ import Handler.Shared
|
|||||||
import Handler.Extract
|
import Handler.Extract
|
||||||
|
|
||||||
import System.Directory (doesFileExist)
|
import System.Directory (doesFileExist)
|
||||||
|
import System.FilePath.Find as SFF
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
import Crypto.Hash.SHA1
|
||||||
|
|
||||||
|
import PersistSHA1
|
||||||
|
|
||||||
getCreateChallengeR :: Handler Html
|
getCreateChallengeR :: Handler Html
|
||||||
getCreateChallengeR = do
|
getCreateChallengeR = do
|
||||||
(formWidget, formEnctype) <- generateFormPost sampleForm
|
(formWidget, formEnctype) <- generateFormPost sampleForm
|
||||||
let submission = Nothing :: Maybe (FileInfo, Text)
|
let submission = Nothing :: Maybe (Import.FileInfo, Text)
|
||||||
handlerName = "getCreateChallengeR" :: Text
|
handlerName = "getCreateChallengeR" :: Text
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
aDomId <- newIdent
|
aDomId <- newIdent
|
||||||
@ -62,8 +67,62 @@ addChallenge name publicRepoId privateRepoId chan = do
|
|||||||
challengeTitle=(T.pack $ title),
|
challengeTitle=(T.pack $ title),
|
||||||
challengeDescription=(T.pack $ description),
|
challengeDescription=(T.pack $ description),
|
||||||
challengeStamp=time}
|
challengeStamp=time}
|
||||||
|
updateTests challengeId chan
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
|
updateTests :: (Key Challenge) -> Channel -> Handler ()
|
||||||
|
updateTests challengeId chan = do
|
||||||
|
challenge <- runDB $ get404 challengeId
|
||||||
|
let repoId = challengePrivateRepo challenge
|
||||||
|
let repoDir = getRepoDir repoId
|
||||||
|
repo <- runDB $ get404 repoId
|
||||||
|
let commit = repoCurrentCommit repo
|
||||||
|
testDirs <- liftIO $ findTestDirs repoDir
|
||||||
|
mapM_ (checkTestDir chan challengeId commit) testDirs
|
||||||
|
msg chan (T.pack $ show testDirs)
|
||||||
|
return ()
|
||||||
|
|
||||||
|
expectedFileName = "expected.tsv"
|
||||||
|
|
||||||
|
doesExpectedExist :: FilePath -> IO Bool
|
||||||
|
doesExpectedExist fp = doesFileExist (fp </> expectedFileName)
|
||||||
|
|
||||||
|
checkTestDir :: Channel -> (Key Challenge) -> SHA1 -> FilePath -> Handler ()
|
||||||
|
checkTestDir chan challengeId commit testDir = do
|
||||||
|
expectedExists <- liftIO $ doesExpectedExist testDir
|
||||||
|
if expectedExists
|
||||||
|
then do
|
||||||
|
msg chan $ concat ["Test dir ", (T.pack testDir), " found."]
|
||||||
|
checksum <- liftIO $ gatherSHA1 testDir
|
||||||
|
testId <- runDB $ insert $ Test {
|
||||||
|
testChallenge=challengeId,
|
||||||
|
testChecksum=(SHA1 checksum),
|
||||||
|
testCommit=commit,
|
||||||
|
testActive=True }
|
||||||
|
return ()
|
||||||
|
else
|
||||||
|
msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."]
|
||||||
|
return ()
|
||||||
|
|
||||||
|
|
||||||
|
gatherSHA1 :: FilePath -> IO ByteString
|
||||||
|
gatherSHA1 testDir = do
|
||||||
|
files <- SFF.find always isTestDirHashedFile testDir
|
||||||
|
contentss <- mapM readFile $ sort files
|
||||||
|
return $ finalize $ foldl' Crypto.Hash.SHA1.update init contentss
|
||||||
|
|
||||||
|
isTestDirHashedFile :: FindClause Bool
|
||||||
|
isTestDirHashedFile = fileType ==? RegularFile
|
||||||
|
|
||||||
|
|
||||||
|
findTestDirs :: FilePath -> IO [FilePath]
|
||||||
|
findTestDirs = SFF.find never testDirFilter
|
||||||
|
|
||||||
|
never :: FindClause Bool
|
||||||
|
never = depth ==? 0
|
||||||
|
|
||||||
|
testDirFilter :: FindClause Bool
|
||||||
|
testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*")
|
||||||
|
|
||||||
sampleForm :: Form (Text, Text, Text, Text, Text)
|
sampleForm :: Form (Text, Text, Text, Text, Text)
|
||||||
sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,)
|
sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,)
|
||||||
|
@ -97,6 +97,8 @@ library
|
|||||||
, random
|
, random
|
||||||
, pandoc
|
, pandoc
|
||||||
, pandoc-types
|
, pandoc-types
|
||||||
|
, filemanip
|
||||||
|
, cryptohash
|
||||||
|
|
||||||
executable gonito
|
executable gonito
|
||||||
if flag(library-only)
|
if flag(library-only)
|
||||||
|
Loading…
Reference in New Issue
Block a user