gonito/Handler/CreateChallenge.hs

module Handler.CreateChallenge where

import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
                              withSmallInput)

import Handler.Shared
import Handler.Extract

import System.Directory (doesFileExist)
import System.FilePath.Find as SFF
import System.FilePath
import qualified Data.Text as T

import PersistSHA1

getCreateChallengeR :: Handler Html
getCreateChallengeR = do
    (formWidget, formEnctype) <- generateFormPost sampleForm
    let submission = Nothing :: Maybe (Import.FileInfo, Text)
        handlerName = "getCreateChallengeR" :: Text
    defaultLayout $ do
        aDomId <- newIdent
        setTitle "Welcome To Yesod!"
        $(widgetFile "create-challenge")

postCreateChallengeR :: Handler TypedContent
postCreateChallengeR = do
    ((result, formWidget), formEnctype) <- runFormPost sampleForm
    let handlerName = "postCreateChallengeR" :: Text
        challengeData = case result of
            FormSuccess res -> Just res
            _ -> Nothing
        Just (name, publicUrl, publicBranch, privateUrl, privateBranch) = challengeData

    runViewProgress $ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch

doCreateChallenge :: Text -> Text -> Text -> Text -> Text -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do
  maybePublicRepoId <- cloneRepo publicUrl publicBranch chan
  case maybePublicRepoId of
    Just publicRepoId -> do
      maybePrivateRepoId <- cloneRepo privateUrl privateBranch chan
      case maybePrivateRepoId of
          Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan
          Nothing -> return ()
    Nothing -> return ()

addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId chan = do
  msg chan "adding challenge..."
  let publicRepoDir = getRepoDir publicRepoId
  let readmeFilePath = publicRepoDir </> readmeFile
  doesReadmeExist <- liftIO $ doesFileExist readmeFilePath
  (title, description) <- if doesReadmeExist
                           then
                            liftIO $ extractTitleAndDescription readmeFilePath
                           else do
                            err chan "README was not found"
                            return (defaultTitle, defaultDescription)
  time <- liftIO getCurrentTime
  challengeId <- runDB $ insert $ Challenge {
    challengePublicRepo=publicRepoId,
    challengePrivateRepo=privateRepoId,
    challengeName=name,
    challengeTitle=(T.pack $ title),
    challengeDescription=(T.pack $ description),
    challengeStamp=time}
  updateTests challengeId chan
  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,
        testName=T.pack $ takeFileName testDir,
        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
  gatherSHA1ForCollectionOfFiles files

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 = renderBootstrap3 BootstrapBasicForm $ (,,,,)
    <$> areq textField (fieldSettingsLabel MsgName) Nothing
    <*> areq textField (fieldSettingsLabel MsgPublicUrl) Nothing
    <*> areq textField (fieldSettingsLabel MsgBranch) Nothing
    <*> areq textField (fieldSettingsLabel MsgPrivateUrl) Nothing
    <*> areq textField (fieldSettingsLabel MsgBranch) Nothing