Implement --submit command

geval.cabal

@@ -29,6 +29,7 @@ library
                      , GEval.BIO
                      , GEval.ParseParams
                      , GEval.ProbList
+                     , GEval.Submit
                      , Data.Conduit.AutoDecompress
                      , Data.Conduit.SmartSource
                      , Data.Conduit.Rank
@@ -70,6 +71,8 @@ library
                      , containers
                      , statistics
                      , pcre-heavy
+                     , process
+                     , uri-encode
   default-language:    Haskell2010
 
 executable geval
@@ -103,6 +106,10 @@ test-suite geval-test
                      , conduit-extra
                      , conduit
                      , containers
+                     , process
+                     , directory
+                     , temporary
+                     , silently
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
 

src/GEval/Core.hs

@@ -216,7 +216,9 @@ data GEvalSpecification = GEvalSpecification
                             gesInputFile :: String,
                             gesMetrics :: [Metric],
                             gesPrecision :: Maybe Int,
-                            gesTokenizer :: Maybe Tokenizer }
+                            gesTokenizer :: Maybe Tokenizer,
+                            gesGonitoHost :: Maybe String,
+                            gesToken :: Maybe String }
 
 gesMainMetric :: GEvalSpecification -> Metric
 gesMainMetric spec = case gesMetrics spec of
@@ -235,7 +237,7 @@ getExpectedDirectory spec = fromMaybe outDirectory $ gesExpectedDirectory spec
 data GEvalSpecialCommand = Init
                            | LineByLine | WorstFeatures
                            | Diff FilePath | MostWorseningFeatures FilePath
-                           | PrintVersion | JustTokenize
+                           | PrintVersion | JustTokenize | Submit
 
 data ResultOrdering = KeepTheOriginalOrder | FirstTheWorst | FirstTheBest
 

src/GEval/OptionsParser.hs

@@ -25,6 +25,7 @@ import Data.Monoid ((<>))
 import GEval.Core
 import GEval.CreateChallenge
 import GEval.LineByLine
+import GEval.Submit (submit)
 
 import Data.Conduit.SmartSource
 
@@ -68,7 +69,13 @@ optionsParser = GEvalOptions
                 (flag' JustTokenize
                     ( long "just-tokenize"
                       <> short 'j'
-                      <> help "Just tokenise standard input and print out the tokens (separated by spaces) on the standard output. rather than do any evaluation. The --tokenizer option must be given.")))
+                      <> help "Just tokenise standard input and print out the tokens (separated by spaces) on the standard output. rather than do any evaluation. The --tokenizer option must be given."))
+                <|>
+                (flag' Submit
+                    ( long "submit"
+                      <> short 'S'
+                      <> help "Submit current solution for evalution to an external Gonito instance specified with --gonito-host option. Optionally, specify --token."))
+                )
 
    <*> ((flag' FirstTheWorst
          (long "sort"
@@ -136,6 +143,18 @@ specParser = GEvalSpecification
          <> short 'T'
          <> metavar "TOKENIZER"
          <> help "Tokenizer on expected and actual output before running evaluation (makes sense mostly for metrics such BLEU), minimalistic, 13a and v14 tokenizers are implemented so far. Will be also used for tokenizing text into features when in --worst-features and --most-worsening-features modes." ))
+  <*> ( optional . strOption $
+        ( long "gonito-host"
+          <> metavar "GONITO_HOST"
+          <> help "Submit ONLY: Gonito instance location."
+        )
+      )
+  <*> ( optional . strOption $
+        ( long "token"
+          <> metavar "TOKEN"
+          <> help "Submit ONLY: Token for authorization with Gonito instance."
+        )
+      )
 
 singletonMaybe :: Maybe a -> Maybe [a]
 singletonMaybe (Just x) = Just [x]
@@ -230,6 +249,9 @@ runGEval''' (Just (MostWorseningFeatures otherOut)) ordering spec = do
 runGEval''' (Just JustTokenize) _ spec = do
   justTokenize (gesTokenizer spec)
   return Nothing
+runGEval''' (Just Submit) _ spec = do
+  submit (gesGonitoHost spec) (gesToken spec)
+  return Nothing
 
 initChallenge :: GEvalSpecification -> IO ()
 initChallenge spec = case gesExpectedDirectory spec of

src/GEval/Submit.hs

@@ -0,0 +1,131 @@
+module GEval.Submit (
+  submit,
+
+  getToken,
+  readToken,
+  writeToken,
+  tokenFilePath,
+
+  getCurrentBranch,
+  getChallengeId,
+  getRepoRoot,
+  getRemoteUrl,
+
+  checkEverythingCommitted,
+  checkRemoteSynced
+) where
+
+import Data.Char (toLower)
+
+import System.Process hiding (runCommand)
+import System.IO
+import System.IO.Error
+import System.Exit
+import System.Directory
+import System.FilePath
+
+import Network.HTTP.Simple
+import Network.URI.Encode (encode)
+import qualified Data.ByteString.Char8 as BS
+
+submit :: Maybe String -> Maybe String -> IO ()
+submit Nothing _ = failWith "ERROR: Please provide --gonito-host"
+submit (Just host) tok = do
+  token <- getToken tok
+  branch <- getCurrentBranch
+  challengeId <- getChallengeId
+  repoUrl <- getRemoteUrl "origin"
+  if branch == "master" || branch == "dont-peek" then
+    failWith $  "ERROR: Run on prohibited branch " ++ branch
+  else do
+    checkEverythingCommitted
+    checkRemoteSynced
+    trigger host token branch challengeId repoUrl
+
+trigger :: String -> String -> String -> String -> String -> IO ()
+trigger host token branch challengeId repoUrl = do
+    req <- parseRequest url
+    httpBS req >>= BS.putStrLn . getResponseBody
+  where url = "POST http://" ++ host ++ "/trigger-remotely?token=" ++ (encode token) ++ "&branch=" ++ (encode branch) ++ "&challenge=" ++ (encode challengeId) ++ "&url=" ++ (encode repoUrl)
+
+getToken :: Maybe String -> IO String
+getToken (Just token) = do
+  dotToken <- readToken
+  case dotToken of
+    Just token' -> do
+      if token /= token' then do
+        putStrLn "WARNING: Token found in .token file is different then one specified through commandline. Overwrite? [Y/N]:"
+        answer <- getChar
+        case toLower answer of
+          'y' -> writeToken token
+          'n' -> return ()
+      else return ()
+    Nothing -> writeToken token
+  return token
+getToken Nothing = do
+  dotToken <- readToken
+  case dotToken of
+    Just token -> return token
+    Nothing -> do
+      putStrLn "WARNING: No token specified. Please provide your token below:"
+      token <- getLine
+      writeToken token
+      return token
+
+checkEverythingCommitted :: IO ()
+checkEverythingCommitted = do
+  callCommand "git update-index -q --ignore-submodules --refresh"
+  (code, _, _) <- readCreateProcessWithExitCode (shell "git diff-index --quiet HEAD --") ""
+  case code of
+    ExitSuccess -> return ()
+    ExitFailure _ -> failWith "ERROR: Uncommitted changes."
+
+checkRemoteSynced :: IO ()
+checkRemoteSynced = do
+  (_, _, _, pr) <- createProcess (shell "git fetch")
+  waitForProcess pr
+  localHash <- runCommand "git rev-parse HEAD"
+  remoteTrackingBranch <- runCommand "git rev-parse --abbrev-ref --symbolic-full-name @{u}"
+  remoteHash <- runCommand $ "git rev-parse " ++ remoteTrackingBranch
+  if localHash == remoteHash then
+    return ()
+  else
+    failWith "ERROR: Changes are not merged with remote branch."
+
+getCurrentBranch :: IO String
+getCurrentBranch = runCommand "git rev-parse --abbrev-ref HEAD"
+
+getRemoteUrl :: String -> IO String
+getRemoteUrl remote = runCommand $ "git config --get remote." ++ remote ++ ".url"
+
+getChallengeId :: IO String
+getChallengeId = getCurrentDirectory >>= return . takeBaseName
+
+getRepoRoot :: IO String
+getRepoRoot = runCommand "git rev-parse --show-toplevel"
+
+tokenFilePath :: IO String
+tokenFilePath = (++ "/.token" ) <$> getRepoRoot
+
+readToken :: IO (Maybe String)
+readToken = do
+  file <- tokenFilePath
+  catchIOError
+    (Just . takeWhile (/= '\n') <$> readFile file)
+    (\e -> if isDoesNotExistError e
+           then return Nothing
+           else failWith "ERROR: Unable to read .token file" >> return Nothing
+    )
+
+writeToken :: String -> IO ()
+writeToken token = do
+  file <- tokenFilePath
+  catchIOError (writeFile file token) (\_ -> failWith "ERROR: Unable to write .token file")
+
+runCommand :: String -> IO String
+runCommand cmd = do
+  content <- readCreateProcess (shell cmd) ""
+  return $ takeWhile (/= '\n') content
+
+failWith :: String -> IO ()
+failWith msg = hPutStrLn stderr msg >> exitFailure

test/Spec.hs

@@ -12,6 +12,7 @@ import GEval.ClusteringMetrics
 import GEval.BIO
 import GEval.LineByLine
 import GEval.ParseParams
+import GEval.Submit
 import Text.Tokenizer
 import Data.Attoparsec.Text
 import Options.Applicative
@@ -22,6 +23,13 @@ import Data.Map.Strict
 
 import Data.Conduit.List (consume)
 
+import System.Directory
+import System.Process
+import System.Exit
+import System.IO
+import System.IO.Temp
+import System.IO.Silently
+
 import qualified Test.HUnit as HU
 
 import Data.Conduit.SmartSource
@@ -398,6 +406,44 @@ main = hspec $ do
       tokenize (Just V13a) "To be or not to be, that's the question." `shouldBe`
         ["To", "be", "or", "not", "to", "be",
          ",", "that's", "the", "question", "."]
+  describe "submit" $ do
+    it "current branch" $ do
+      runGitTest "branch-test" (\_ -> getCurrentBranch) `shouldReturn` "develop"
+    it "challengeId" $ do
+      runGitTest "challengeId-test" (
+        \_ -> do
+          path <- makeAbsolute "challenge01"
+          setCurrentDirectory path
+          getChallengeId) `shouldReturn` "challenge01"
+    it "everything committed - positive" $ do
+      runGitTest "everythingCommitted-test-pos" (\_ -> checkEverythingCommitted) `shouldReturn` ()
+    it "everything committed - negative" $ do
+      hSilence [stderr] $ runGitTest "everythingCommitted-test-neg" (\_ -> checkEverythingCommitted) `shouldThrow` (== ExitFailure 1)
+    it "remote synced - positive" $ do
+      runGitTest "remoteSynced-test-pos" (\_ -> checkRemoteSynced) `shouldReturn` ()
+    it "remote synced - negative" $ do
+      hSilence [stderr] $ runGitTest "remoteSynced-test-neg" (\_ -> checkRemoteSynced) `shouldThrow` (== ExitFailure 1)
+    it "remote url" $ do
+      runGitTest "remoteUrl-test" (\_ -> getRemoteUrl "origin") `shouldReturn` "git@git.example.com:example/example.git"
+    it "repo root" $ do
+      runGitTest "repoRoot-test" (
+        \path -> do
+          subpath <- makeAbsolute "A/B"
+          setCurrentDirectory subpath
+          root <- getRepoRoot
+          return $ root == path
+        ) `shouldReturn` True
+    it "no token" $ do
+      runGitTest "token-test-no" (\_ -> readToken) `shouldReturn` Nothing
+    it "read token" $ do
+      runGitTest "token-test-yes" (\_ -> readToken) `shouldReturn` (Just "AAAA")
+    it "write-read token" $ do
+      runGitTest "token-test-no" (
+        \_ -> do
+          writeToken "BBBB"
+          token <- readToken
+          return $ token == (Just "BBBB")
+       ) `shouldReturn` True
 
 checkConduitPure conduit inList expList = do
   let outList = runConduitPure $ CC.yieldMany inList .| conduit .| CC.sinkList
@@ -458,3 +504,13 @@ shouldBeAlmost got expected = got @=~? expected
 
 shouldReturnAlmost :: (AEq a, Show a, Eq a) => IO a -> a -> Expectation
 shouldReturnAlmost action expected = action >>= (@=~? expected)
+
+runGitTest :: String -> (FilePath -> IO a) -> IO a
+runGitTest name callback = do
+  withTempDirectory "/tmp" "geval-submit-test" $ \temp -> do
+    copyFile ("test/_submit-tests/" ++ name ++ ".tar") (temp ++ "/" ++ name ++ ".tar")
+    withCurrentDirectory temp $ do
+      callCommand $ "tar xf " ++ name ++ ".tar"
+    let testRoot = temp ++ "/" ++ name
+    withCurrentDirectory testRoot $ do
+      callback testRoot