gonito/Handler/ShowChallenge.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}

module Handler.ShowChallenge where

import Import hiding (Proxy, fromList)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)

import qualified Data.Text.Lazy as TL
import           Text.Markdown

import qualified Data.Text as T

import qualified Data.HashMap.Strict as HMS

import qualified Yesod.Table as Table

import Control.Concurrent.Lifted (threadDelay)

import Handler.Extract
import Handler.Shared
import Handler.Runner
import Handler.Tables
import Handler.TagUtils
import Handler.MakePublic
import Handler.Dashboard
import Handler.Common
import Handler.Evaluate
import Handler.JWT
import Handler.Team

import Database.Persist.Sql (fromSqlKey)

import qualified Data.Map as Map

import Web.Announcements

import Data.Maybe (fromJust)

import Text.Blaze

import Data.Aeson

import Gonito.ExtractMetadata (ExtractionOptions(..),
                               extractMetadataFromRepoDir,
                               GonitoMetadata(..),
                               parseTags,
                               Link(..))

import qualified Text.Read as TR

import GEval.Core
import GEval.EvaluationScheme

import PersistSHA1

import System.IO (readFile)

import Data.Text (pack, unpack)

import Data.List (nub)

import qualified Database.Esqueleto      as E
import           Database.Esqueleto      ((^.))

import Data.Swagger hiding (get)
import qualified Data.Swagger as DS

import Data.Swagger.Declare
import Control.Lens hiding ((.=), (^.))
import Data.Proxy as DPR
import Data.HashMap.Strict.InsOrd (fromList)

instance ToJSON LeaderboardEntry where
    toJSON entry = object
        [ "submitter" .= (formatSubmitter $ leaderboardUser entry)
        , "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry)
        , "when" .= (submissionStamp $ leaderboardBestSubmission entry)
        , "version" .= leaderboardVersion entry
        , "description" .= descriptionToBeShown (leaderboardBestSubmission entry)
                                                (leaderboardBestVariant entry)
                                                (leaderboardParams entry)
        , "times" .= leaderboardNumberOfSubmissions entry
        , "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
        , "isPublic" .= (submissionIsPublic $ leaderboardBestSubmission entry)
        , "isReevaluable" .= (leaderboardIsReevaluable entry)
        , "isVisible" .= (leaderboardIsVisible entry)
        , "id" .= (leaderboardBestSubmissionId entry)
        , "variant" .= (leaderboardBestVariantId entry)
        ]

declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
declareLeaderboardSwagger = do
  -- param schemas
  let challengeNameSchema = toParamSchema (Proxy :: Proxy String)

  leaderboardResponse      <- declareResponse (Proxy :: Proxy LeaderboardView)

  return $ mempty
    & paths .~
        fromList [ ("/api/leaderboard/{challengeName}",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ Inline $ mempty
                                                          & name .~ "challengeName"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ challengeNameSchema) ]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ "Returns a leaderboard for a given challenge"
                                        & at 200 ?~ Inline leaderboardResponse))
                 ]


leaderboardApi :: Swagger
leaderboardApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareLeaderboardSwagger mempty

data LeaderboardView = LeaderboardView {
  leaderboardViewTests :: [Entity Test],
  leaderboardViewEntries :: [LeaderboardEntryView]
}

instance ToJSON LeaderboardView where
    toJSON v = object
        [ "tests" .= (map getTestReference $ leaderboardViewTests v)
        , "entries" .= leaderboardViewEntries v
        ]

instance ToSchema LeaderboardView where
  declareNamedSchema _ = do
    testsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
    entriesSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [LeaderboardEntryView])
    return $ NamedSchema (Just "Leaderboard") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [  ("tests", testsSchema)
                     , ("entries", entriesSchema)
                    ]
        & required .~ [ "tests", "entries" ]

getLeaderboardJsonR :: Text -> Handler Value
getLeaderboardJsonR challengeName = do
  Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
  leaderboardStyle <- determineLeaderboardStyle challenge
  (leaderboard, (_, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
  return $ toJSON $ LeaderboardView {
    leaderboardViewTests = tests,
    leaderboardViewEntries = map (toLeaderboardEntryView tests) leaderboard }

data LeaderboardEntryView = LeaderboardEntryView {
  leaderboardEntryViewEntry :: LeaderboardEntry,
  leaderboardEntryViewEvaluations :: [EvaluationView]
}

addJsonKey :: Text -> Value -> Value -> Value
addJsonKey key val (Object xs) = Object $ HMS.insert key val xs
addJsonKey _ _ xs = xs


-- Helper definitions for properties used in more than one place

isVisibleSchema :: Referenced Schema
isVisibleSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Bool)
  & description .~ Just "Whether the details of the submissions are visible (i.e. either the submission is public or the user has the right permissions)"

isPublicSchema :: Referenced Schema
isPublicSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Bool)
  & description .~ Just "Whether the submissions is public (i.e. whether its details are available to everyone)"

hashSchema :: Referenced Schema
hashSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
  & description .~ Just "Git SHA1 commit hash; could be used as an argument for queries (if the submission is visible)"
  & example .~ Just "ec41f0e2636bfedbd765c9871c813f7c5b896c51"

versionSchema :: Referenced Schema
versionSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy [Int])
  & description .~ Just "Challenge version under which the submission was done"
  & example .~ Just (toJSON [2 :: Int, 0, 1])

submitterSchema :: Referenced Schema
submitterSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
  & description .~ Just ("Name of the submitter, might be a special value in square brackets, e.g. " <> anonymizedLabel <> " or " <> nameNotGivenLabel)
  & example .~ Just "John Smith"

submissionIdSchema :: Referenced Schema
submissionIdSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
  & description .~ Just "Internal database identifier of the submission"
  & example .~ Just(toJSON (42 :: Int))

variantIdSchema :: Referenced Schema
variantIdSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
  & description .~ Just "Internal database identifier of the submission variant"
  & example .~ Just (toJSON (53 :: Int))



instance ToJSON LeaderboardEntryView where
    toJSON v = addJsonKey "evaluations"
                           (toJSON $ leaderboardEntryViewEvaluations v)
                           (toJSON $ leaderboardEntryViewEntry v)

instance ToSchema LeaderboardEntryView where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
    boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
    evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])

    return $ NamedSchema (Just "LeaderboardEntry") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [  ("submitter", submitterSchema)
                     , ("team", stringSchema)
                     , ("when", stringSchema)
                     , ("version", versionSchema)
                     , ("description", stringSchema)
                     , ("times", Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
                                           & description .~ Just "How many times a submission from the same user/of the same tag was submitted"
                                           & minProperties .~ Just 1
                                           & example .~ Just (toJSON (2:: Int)))
                     , ("hash", hashSchema)
                     , ("evaluations", evaluationsSchema)
                     , ("isPublic", isPublicSchema)
                     , ("isReevaluable", boolSchema)
                     , ("isVisible", isVisibleSchema)
                     , ("id", submissionIdSchema)
                     , ("variantId", variantIdSchema)
                    ]
        & required .~ [ "submitter", "when", "version", "description", "times", "hash", "evaluations" ]

toLeaderboardEntryView :: [(Entity Test)] -> LeaderboardEntry -> LeaderboardEntryView
toLeaderboardEntryView tests entry = LeaderboardEntryView {
  leaderboardEntryViewEntry = entry,
  leaderboardEntryViewEvaluations = catMaybes $
                                    map (convertEvaluationToView (leaderboardEvaluationMap entry)) tests
  }

determineLeaderboardStyle :: Challenge -> Handler LeaderboardStyle
determineLeaderboardStyle challenge = do
  app <- getYesod
  let leaderboardStyle = appLeaderboardStyle $ appSettings app
  return $ case challengeIsCompetition challenge of
             Just True -> BySubmitter
             _ -> leaderboardStyle

getShowChallengeR :: Text -> Handler Html
getShowChallengeR challengeName = do
  app <- getYesod
  challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
  leaderboardStyle <- determineLeaderboardStyle challenge

  isHealthy <- isChallengeHealthy challenge

  Just repo <- runDB $ get $ challengePublicRepo challenge
  (leaderboard, (entries, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId

  showAltLeaderboard <- runDB $ hasMetricsOfSecondPriority challengeId

  (altLeaderboard, altTests) <- if showAltLeaderboard
                               then
                                do
                                 (leaderboard', (_, tests')) <- getLeaderboardEntries 3 ByTag challengeId
                                 return $ (Just leaderboard', Just tests')
                               else
                                 return (Nothing, Nothing)

  mauth <- maybeAuth

  let params = getNumericalParams entries

  let scheme = appRepoScheme $ appSettings app

  challengeRepo <- runDB $ get404 $ challengePublicRepo challenge

  challengeLayout True challenge (showChallengeWidget mauth
                                                      challengeEnt
                                                      scheme
                                                      challengeRepo
                                                      repo
                                                      leaderboard
                                                      altLeaderboard
                                                      params
                                                      tests
                                                      altTests
                                                      isHealthy)

hasMetricsOfSecondPriority :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m Bool
hasMetricsOfSecondPriority challengeId = do
  tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True] []
  let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) == 2) tests'
  return $ not (null tests)


getChallengeReadmeR :: Text -> Handler Html
getChallengeReadmeR challengeName = do
  (Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
  readme <- challengeReadme challengeName
  challengeLayout False challenge $ toWidget readme

challengeReadmeInMarkdownApi :: Swagger
challengeReadmeInMarkdownApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareChallengeReadmeInMarkdownSwagger mempty

declareChallengeReadmeInMarkdownSwagger :: Declare (Definitions Schema) Swagger
declareChallengeReadmeInMarkdownSwagger = do
  -- param schemas
  let challengeNameSchema = toParamSchema (Proxy :: Proxy String)

  return $ mempty
    & paths .~
        fromList [ ("/api/challenge-readme/{challengeName}/markdown",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ Inline $ mempty
                                                          & name .~ "challengeName"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ challengeNameSchema) ]
                                        & produces ?~ MimeList ["application/text"]
                                        & description ?~ "Returns the challenge README in Markdown"))
                 ]

getChallengeReadmeInMarkdownR :: Text -> Handler TL.Text
getChallengeReadmeInMarkdownR challengeName = doChallengeReadmeContents challengeName

challengeReadme :: Text -> Handler Html
challengeReadme challengeName = do
  theContents <- doChallengeReadmeContents challengeName
  return $ markdown def theContents

-- Checks whether the directories with repos are available
isChallengeHealthy :: Challenge -> Handler Bool
isChallengeHealthy challenge = do
  publicRepoDirExists <- doesRepoExistsOnTheDisk $ challengePublicRepo challenge
  privateRepoDirExists <- doesRepoExistsOnTheDisk $ challengePrivateRepo challenge
  return $ publicRepoDirExists && privateRepoDirExists

doChallengeReadmeContents :: Text -> Handler TL.Text
doChallengeReadmeContents challengeName = do
  (Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
  let repoId = challengePublicRepo challenge
  repoDir <- getRepoDir repoId
  let readmeFilePath = repoDir </> readmeFile
  theContents <- liftIO $ System.IO.readFile readmeFilePath
  return $ TL.pack theContents

showChallengeWidget :: Maybe (Entity User)
                      -> Entity Challenge
                      -> RepoScheme
                      -> Repo
                      -> Repo
                      -> [LeaderboardEntry]
                      -> (Maybe [LeaderboardEntry])
                      -> [Text]
                      -> [Entity Test]
                      -> (Maybe [Entity Test])
                      -> Bool
                      -> WidgetFor App ()
showChallengeWidget mUserEnt
                    (Entity challengeId challenge)
                    scheme
                    challengeRepo
                    repo
                    leaderboard
                    mAltLeaderboard
                    params
                    tests
                    mAltTests
                    isHealthy
  = $(widgetFile "show-challenge")
  where leaderboardWithRanks = zip [1..] leaderboard
        mAltLeaderboardWithRanks = zip [1..] <$> mAltLeaderboard
        maybeRepoLink = getRepoLink repo
        delta = Number 4
        higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
        mUserId = entityKey <$> mUserEnt

data GitServer = Gogs | GitLab | GitHub | Gonito
  deriving (Eq, Show)

guessGitServer :: Text -> Maybe GitServer
guessGitServer bareUrl
  | "git.wmi.amu.edu.pl" `isPrefixOf` bareUrl = Just Gogs
  | "gitlab." `isPrefixOf` bareUrl = Just GitLab
  | "git." `isPrefixOf` bareUrl = Just GitLab
  | "github." `isPrefixOf` bareUrl = Just GitHub
  | "gonito.net" `isPrefixOf` bareUrl = Just Gonito
  | otherwise = Nothing

getHttpLink :: Repo -> Maybe (Text, Text)
getHttpLink repo = case guessGitServer bareUrl of
  Just Gogs -> Just (convertToHttpLink bareUrl, "/src/" <> branch)
  Just GitLab -> Just (convertToHttpLink bareUrl, "/-/tree/" <> branch)
  Just GitHub -> Just (convertToHttpLink bareUrl, "/tree/" <> branch)
  Just Gonito -> Just (fixGonito $ convertToHttpLink bareUrl, "/" <> branch)
  Nothing -> Nothing
  where bareUrl = removeProtocol $ removeLogin rurl
        removeLogin t = r
          where (_, r) = T.breakOnEnd "@" t
        rurl = repoUrl repo
        branch = repoBranch repo
        convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
        removeProtocol = stripPrefixes ["https://", "http://", "git://", "ssh://",
                                        "ssh." -- when a domain with ssh. prefix is used
                                       ]
        stripPrefixes prefixes t = foldr stripPrefixFrom t prefixes
        stripPrefixFrom pref t = if pref `isPrefixOf` t
                                   then drop (length pref) t
                                   else t
        fixGonito t = (T.replace "https://gonito.net" "https://gonito.net/gitlist" t) <> ".git"

getRepoLink :: Repo -> Maybe Text
getRepoLink repo = case getHttpLink repo of
  Just (hostname, linkRest) -> Just $ hostname <> linkRest
  Nothing -> if sitePrefix `isPrefixOf` theUrl
            then Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
            else Nothing
  where sitePrefix = "git://gonito.net/" :: Text
        sitePrefixLen = length sitePrefix
        theUrl = repoUrl repo
        bareRepoName = drop sitePrefixLen theUrl

instance ToJSON (Repo) where
    toJSON repo = object
        [ "url"  .= repoUrl repo
        , "branch" .= repoBranch repo
        , "browsableUrl" .= getRepoLink repo
        ]

instance ToSchema (Repo) where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (Proxy :: Proxy String)
    return $ NamedSchema (Just "DataRepository") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [ ("url", Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
                              & description .~ Just "Git URL to be cloned (https://, git:// or ssh:// protocol)"
                              & example .~ Just (toJSON ("git://gonito.net/fiszki-ocr" :: String)))
                    , ("branch", stringSchema)
                    , ("browsableUrl", Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
                                           & description .~ Just "An URL address that your browser can open; usually, but not always available"
                                           & example .~ Just (toJSON ("https://github.com/applicaai/kleister-charity/tree/master" :: String)))

                    ]
        & required .~ [ "url", "branch" ]

getChallengeRepoJsonR :: Text -> Handler Value
getChallengeRepoJsonR chName = do
  (Entity _ challenge) <- runDB $ getBy404 $ UniqueName chName
  repo <- runDB $ get404 $ challengePublicRepo challenge
  return $ toJSON repo

declareChallengeRepoSwagger :: Declare (Definitions Schema) Swagger
declareChallengeRepoSwagger = do
  -- param schemas
  let challengeNameSchema = toParamSchema (Proxy :: Proxy String)

  return $ mempty
    & paths .~
        fromList [ ("/api/challenge-repo/{challengeName}",
            mempty & DS.get ?~ (mempty
                                 & parameters .~ [ Inline $ mempty
                                                   & name .~ "challengeName"
                                                   & required ?~ True
                                                   & schema .~ ParamOther (mempty
                                                                            & in_ .~ ParamPath
                                                                            & paramSchema .~ challengeNameSchema) ]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ "Return metadata for the challenge repository"))
        ]

challengeRepoApi :: Swagger
challengeRepoApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareChallengeRepoSwagger mempty


getChallengeHowToR :: Text -> Handler Html
getChallengeHowToR challengeName = do
  (Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
  maybeUser <- maybeAuth

  app <- getYesod
  let settings = appSettings app

  let publicRepoId = challengePublicRepo challenge
  repo <- runDB $ get404 publicRepoId

  case maybeUser of
    Just (Entity userId user) -> do
      enableTriggerToken userId (userTriggerToken user)
    Nothing -> return ()

  let mToken = case maybeUser of
        Just (Entity _ user) -> userTriggerToken user
        Nothing -> Nothing

  let isIDSet = case maybeUser of
                  Just (Entity _ user) -> isJust $ userLocalId user
                  Nothing -> False
  isSSHUploaded <- case maybeUser of
    Just (Entity userId _) -> do
      ukeys <- runDB $ selectList [PublicKeyUser ==. userId] []
      return $ not (null ukeys)
    Nothing -> return False
  challengeLayout False challenge (challengeHowTo
                                   challenge
                                   settings
                                   repo
                                   (idToBeShown challenge maybeUser)
                                   isIDSet
                                   isSSHUploaded
                                   (join $ userAltRepoScheme <$> entityVal <$> maybeUser)
                                   mToken)

idToBeShown :: p -> Maybe (Entity User) -> Text
idToBeShown _ maybeUser =
  case maybeUser of
   Just user ->  case userLocalId $ entityVal user of
                 Just localId -> localId
                 Nothing -> defaultIdToBe
   Nothing -> defaultIdToBe
  where defaultIdToBe = "YOURID" :: Text

defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text
defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
defaultRepo Branches _ _ repo _ = repoUrl repo

defaultBranch :: IsString a => RepoScheme -> Maybe a
defaultBranch SelfHosted = Just "master"
defaultBranch Branches = Nothing

challengeHowTo :: Challenge -> AppSettings -> Repo -> Text -> Bool -> Bool -> Maybe Text -> Maybe Text -> WidgetFor App ()
challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mAltRepoScheme mToken = $(widgetFile "challenge-how-to")
  where myBranch = "my-brilliant-branch" :: Text
        urlToYourRepo = case mAltRepoScheme of
          Just altRepoScheme -> encodeSlash (altRepoScheme <> (challengeName challenge))
          Nothing -> "URL_TO_YOUR_REPO"

postHealR :: ChallengeId -> Handler TypedContent
postHealR challengeId = runViewProgress $ doHeal challengeId

doHeal :: Key Challenge -> Channel -> HandlerFor App ()
doHeal challengeId chan = do
  challenge <- runDB $ get404 challengeId
  _ <- getRepoDirOrClone (challengePrivateRepo challenge) chan
  _ <- getRepoDirOrClone (challengePublicRepo challenge) chan
  return ()

postArchiveR :: ChallengeId -> Handler Html
postArchiveR challengeId = doSetArchive True challengeId

postUnarchiveR :: ChallengeId -> Handler Html
postUnarchiveR challengeId = doSetArchive False challengeId

doSetArchive :: Bool -> ChallengeId -> Handler Html
doSetArchive status challengeId = do
  runDB $ update challengeId [ChallengeArchived =. Just status]
  challenge <- runDB $ get404 challengeId
  getShowChallengeR $ challengeName challenge


archiveForm :: ChallengeId -> Form ChallengeId
archiveForm challengeId = renderBootstrap3 BootstrapBasicForm $ areq hiddenField "" (Just challengeId)

getChallengeSubmissionR :: Text -> Handler Html
getChallengeSubmissionR challengeName = do
   (Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
   maybeUser <- maybeAuth

   Just repo <- runDB $ get $ challengePublicRepo challenge
   app <- getYesod
   let scheme = appRepoScheme $ appSettings app
   let repoHost = appRepoHost $ appSettings app

   let defaultUrl = fromMaybe (defaultRepo scheme repoHost challenge repo maybeUser)
                              ((<> challengeName) <$> (join $ userAltRepoScheme <$> entityVal <$> maybeUser))

   Entity userId _ <- requireAuth

   defaultTeam <- fetchDefaultTeam userId

   (formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) (Just defaultTeam)
   challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge


declareChallengeSubmissionSwagger :: Declare (Definitions Schema) Swagger
declareChallengeSubmissionSwagger = do
  -- param schemas
  let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
  let stringSchema = toParamSchema (Proxy :: Proxy String)

  challengeSubmissionResponse      <- declareResponse (Proxy :: Proxy Int)
  wrongSubmissionResponse      <- declareResponse (Proxy :: Proxy GonitoStatus)

  return $ mempty
    & paths .~
        fromList [ ("/api/challenge-submission/{challengeName}",
                    mempty & DS.post ?~ (mempty
                                         & parameters .~ [ Inline $ mempty
                                                           & name .~ "challengeName"
                                                           & required ?~ True
                                                           & schema .~ ParamOther (mempty
                                                                                   & in_ .~ ParamPath
                                                                                   & paramSchema .~ challengeNameSchema),
                                                           Inline $ mempty
                                                           & name .~ "f1"
                                                           & description .~ Just "submission description"
                                                           & required ?~ False
                                                           & schema .~ ParamOther (mempty
                                                                                   & in_ .~ ParamFormData
                                                                                   & paramSchema .~ stringSchema),
                                                           Inline $ mempty
                                                           & name .~ "f2"
                                                           & description .~ Just "submission tags"
                                                           & required ?~ False
                                                           & schema .~ ParamOther (mempty
                                                                                   & in_ .~ ParamFormData
                                                                                   & paramSchema .~ stringSchema),
                                                           Inline $ mempty
                                                           & name .~ "f3"
                                                           & description .~ Just "repo URL"
                                                           & required ?~ True
                                                           & schema .~ ParamOther (mempty
                                                                                   & in_ .~ ParamFormData
                                                                                   & paramSchema .~ stringSchema),
                                                                                                                      Inline $ mempty
                                                           & name .~ "f4"
                                                           & description .~ Just "repo branch"
                                                           & required ?~ True
                                                           & schema .~ ParamOther (mempty
                                                                                   & in_ .~ ParamFormData
                                                                                   & paramSchema .~ stringSchema),

                                                           Inline $ mempty
                                                           & name .~ "f5"
                                                           & description .~ Just "git-annex remote specification"
                                                           & required ?~ False
                                                           & schema .~ ParamOther (mempty
                                                                                   & in_ .~ ParamFormData
                                                                                   & paramSchema .~ stringSchema)]
                                         & produces ?~ MimeList ["application/json"]
                                         & description ?~ "Initiates a submission based on a given repo URL/branch. Returns an asynchrous job ID."
                                         & at 200 ?~ Inline challengeSubmissionResponse
                                         & at 422 ?~ Inline wrongSubmissionResponse))
                 ]

challengeSubmissionApi :: Swagger
challengeSubmissionApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareChallengeSubmissionSwagger mempty


data ChallangeSubmissionStatus = SubmissionOK | SubmissionWrong Text
  deriving (Eq, Show)

data GonitoStatus = GonitoStatus {
  detail :: Text
  } deriving (Eq, Show, Generic)

instance ToJSON GonitoStatus
instance ToSchema GonitoStatus

postChallengeSubmissionJsonR :: Text -> Handler Value
postChallengeSubmissionJsonR challengeName = do
    Entity userId _ <- requireAuthPossiblyByToken

    challengeEnt@(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
    ((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing Nothing
    let submissionData' = case result of
          FormSuccess res -> Just res
          _ -> Nothing
        Just submissionData = submissionData'

    status <- checkSubmission challengeEnt submissionData

    case status of
      SubmissionOK -> runViewProgressAsynchronously $ doCreateSubmission userId challengeId submissionData
      SubmissionWrong errorMsg -> sendResponseStatus status422 $ toJSON (GonitoStatus errorMsg)

checkSubmission :: Entity Challenge -> ChallengeSubmissionData -> Handler ChallangeSubmissionStatus
checkSubmission (Entity _ challenge) submissionData = do
  let repo = challengeSubmissionDataRepo submissionData
  if (null $ repoSpecUrl repo)
  then
    return $ SubmissionWrong "empty URL"
  else
    do
     if (null $ repoSpecBranch repo)
     then
       return $ SubmissionWrong "empty branch"
     else
       do
        if (willClone challenge submissionData)
        then
         do
          return SubmissionOK
        else
         do
          return $ SubmissionWrong "Refusing to clone the submission from this URL."

postChallengeSubmissionR :: Text -> Handler TypedContent
postChallengeSubmissionR challengeName = do
    userId <- requireAuthId

    (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
    ((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing Nothing
    let submissionData' = case result of
          FormSuccess res -> Just res
          _ -> Nothing
        Just submissionData = submissionData'

    runViewProgress $ doCreateSubmission userId challengeId submissionData

postTriggerLocallyR :: Handler TypedContent
postTriggerLocallyR = do
  (Just challengeName) <- lookupPostParam "challenge"
  (Just localId) <- lookupPostParam "user"
  mBranch <- lookupPostParam "branch"
  mGitAnnexRemote <- lookupPostParam "git-annex-remote"
  [Entity userId _] <- runDB $ selectList [UserLocalId ==. Just localId] []

  app <- getYesod
  let repoHost = appRepoHost $ appSettings app

  let localRepo = repoHost ++ localId ++ "/" ++ challengeName
  trigger userId challengeName localRepo mBranch mGitAnnexRemote

postTriggerRemotelyR :: Handler TypedContent
postTriggerRemotelyR = do
  (Just challengeName) <- lookupPostParam "challenge"
  (Just theUrl) <- lookupPostParam "url"
  (Just token) <- lookupPostParam "token"
  mBranch <- lookupPostParam "branch"
  mGitAnnexRemote <- lookupPostParam "git-annex-remote"
  doTrigger token challengeName theUrl mBranch mGitAnnexRemote

postTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
postTriggerRemotelySimpleR token challengeName theUrl branch =
  doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing

getTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
getTriggerRemotelySimpleR token challengeName theUrl branch =
  doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing

data GitServerPayload = GitServerPayload {
  gitServerPayloadRef :: Text,
  -- Unfortunately, the URL is given in "ssh_url" field
  -- for Gogs and "git_ssh_url" for GitLab, hence two
  -- fields here
  gitServerPayloadSshUrl :: Maybe Text,
  gitServerPayloadGitSshUrl :: Maybe Text
  }
  deriving (Show, Eq)

instance FromJSON GitServerPayload where
    parseJSON (Object o) = GitServerPayload
      <$> o .: "ref"
      <*> ((o .: "repository") >>= (.:? "ssh_url"))
      <*> ((o .: "repository") >>= (.:? "git_ssh_url"))

postTriggerByWebhookR :: Text -> Text -> Handler TypedContent
postTriggerByWebhookR token challengeName = do
  payload <- requireJsonBody :: Handler GitServerPayload
  let ref = gitServerPayloadRef payload
  let refPrefix = "refs/heads/"
  if refPrefix `isPrefixOf` ref
    then
      do
        let branch = T.replace refPrefix "" ref
        let theUrl = fromMaybe (fromJust $ gitServerPayloadGitSshUrl payload)
                            (gitServerPayloadSshUrl payload)
        doTrigger token challengeName theUrl (Just branch) Nothing
    else
      error $ "unexpected ref `" ++ (T.unpack ref) ++ "`"


doTrigger :: Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
doTrigger token challengeName theUrl mBranch mGitAnnexRemote = do
  [Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
  trigger userId challengeName theUrl mBranch mGitAnnexRemote

trigger :: UserId -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
trigger userId challengeName theUrl mBranch mGitAnnexRemote = do
  let branch = fromMaybe "master" mBranch
  mChallengeEnt <- runDB $ getBy $ UniqueName challengeName

  let defSubmission = ChallengeSubmissionData {
        challengeSubmissionDataDescription = Nothing,
        challengeSubmissionDataTags = Nothing,
        challengeSubmissionDataRepo = RepoSpec {
            repoSpecUrl=theUrl,
            repoSpecBranch=branch,
            repoSpecGitAnnexRemote=mGitAnnexRemote},
        challengeSubmissionDataTeam = Nothing
        }

  case mChallengeEnt of
    Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId defSubmission
    Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)

isBefore :: UTCTime -> Maybe UTCTime -> Bool
isBefore _ Nothing = True
isBefore moment (Just deadline) = moment <= deadline

-- | An attempt to filtre out mistaken/unwanted submissions (without cloning
-- the submission repo, just by looking at the metadata)
willClone :: Challenge -> ChallengeSubmissionData -> Bool
willClone challenge submissionData =
  (challengeName challenge) `isInfixOf` theUrl && branch /= dontPeek && not (dontPeek `isInfixOf` theUrl)
  where theUrl = repoSpecUrl $ challengeSubmissionDataRepo submissionData
        branch = repoSpecBranch $ challengeSubmissionDataRepo submissionData
        dontPeek = "dont-peek"


-- | Main place where submission is done (whether manually or by trigger)
doCreateSubmission :: UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
doCreateSubmission userId challengeId challengeSubmissionData chan = do
  challenge <- runDB $ get404 challengeId

  theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
  theNow <- liftIO getCurrentTime

  if theNow `isBefore` (versionDeadline $ entityVal theVersion)
    then
     do
      let wanted = willClone challenge challengeSubmissionData
      if wanted
        then
          doCreateSubmission' (challengeArchived challenge) userId challengeId challengeSubmissionData chan
        else
          msg chan "Refusing to clone the submission from this URL"
    else
      msg chan "Submission is past the deadline, no submission will be accepted from now on."

doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
doCreateSubmission' (Just True) _ _ _ chan = msg chan "This challenge is archived, you cannot submit to it. Ask the site admin to unarchive it."
doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
  let mDescription = challengeSubmissionDataDescription challengeSubmissionData
  let mTags = challengeSubmissionDataTags challengeSubmissionData
  let repoSpec = challengeSubmissionDataRepo challengeSubmissionData

  maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
  case maybeRepoKey of
    Just repoId -> do

      challenge <- runDB $ get404 challengeId
      user <- runDB $ get404 userId

      relevantIndicators <- getOngoingTargets challengeId


      (Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
      let submittedMajorVersion = versionMajor currentVersion

      mMainEnt <- runDB $ fetchMainTest challengeId
      bestScoreSoFar <- case mMainEnt of
        Just (Entity _ mainTest) -> do
          let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
                TheHigherTheBetter -> E.desc
                TheLowerTheBetter -> E.asc

          bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do
              E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
                        E.&&. submission ^. SubmissionIsHidden E.==. E.val False
                        E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
                        E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
                        E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
                        E.&&. out ^. OutVariant E.==. variant ^. VariantId
                        E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
                        E.&&. test ^. TestChallenge E.==. E.val challengeId
                        E.&&. test ^. TestName E.==. E.val (testName mainTest)
                        E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest)
                        E.&&. test ^. TestActive
                        E.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit)
                        E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit
                        E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion)
              E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
              E.limit 1
              return evaluation
          let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
          return bestScoreSoFar'
        Nothing -> return Nothing

      case bestScoreSoFar of
        Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
        Nothing -> msg chan "first submission so far"

      repo <- runDB $ get404 repoId

      repoDir <- getRepoDirOrClone repoId chan

      gonitoMetadata <- liftIO
                       $ extractMetadataFromRepoDir repoDir (ExtractionOptions {
                                                                extractionOptionsDescription = mDescription,
                                                                extractionOptionsTags = Just $ parseTags mTags,
                                                                extractionOptionsGeneralParams = Nothing,
                                                                extractionOptionsUnwantedParams = Nothing,
                                                                extractionOptionsParamFiles = Nothing,
                                                                extractionOptionsMLRunPath = Nothing,
                                                                extractionOptionsExternalLinks = Nothing,
                                                                extractionOptionsDependencies = Nothing })

      mTeamId <- case challengeSubmissionDataTeam challengeSubmissionData of
                  Just tid -> return $ Just tid
                  Nothing -> fetchDefaultTeam userId

      submissionId <- getSubmission userId
                                   mTeamId
                                   repoId
                                   (repoCurrentCommit repo)
                                   challengeId
                                   (gonitoMetadataDescription gonitoMetadata)
                                   chan

      _ <- runDB $ mapM insert $ map (\l -> ExternalLink {
                                        externalLinkSubmission = submissionId,
                                        externalLinkTitle = linkTitle l,
                                        externalLinkUrl = linkUrl l }) $ gonitoMetadataExternalLinks gonitoMetadata

      _ <- runDB $ mapM insertUnique $ map (\s -> Dependency {
                                                  dependencySubRepoCommit = s,
                                                  dependencySuperRepoCommit = (repoCurrentCommit repo) }) $ gonitoMetadataDependencies gonitoMetadata

      outs <- getOuts False chan submissionId (gonitoMetadataGeneralParams gonitoMetadata)

      currentTagIds <- runDB $ selectList [SubmissionTagSubmission ==. submissionId] []

      runDB $ addTags submissionId (gonitoMetadataTags gonitoMetadata)  (
        map (submissionTagTag . entityVal) currentTagIds)
      msg chan "SUBMISSION CREATED"

      app <- getYesod

      let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))

      case mMainEnt of
        Just (Entity mainTestId mainTest) -> do
          newScores <- mapM (getScoreForOut mainTestId) outs
          let newScores' = catMaybes newScores
          let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
                TheHigherTheBetter -> reverse $ sort newScores'
                TheLowerTheBetter -> sort newScores'
          let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
                TheLowerTheBetter -> (<)
                TheHigherTheBetter -> (>)

          case bestScoreSoFar of
            Just b ->  case newScores'' of
                    (s:_) -> if compOp s b
                             then
                              do
                                let challengeLink = slackLink app (challengeTitle challenge) ("challenge/"
                                                                                              ++ (challengeName challenge))
                                let message = ("Whoa! New best result for "
                                               ++ challengeLink
                                               ++ " challenge by "
                                               ++ (fromMaybe "???" $ userName user)
                                               ++ ", "
                                               ++ (T.pack $ show $ testMetric mainTest)
                                               ++ ": "
                                               ++ (formatScore (testPrecision mainTest) s)
                                               ++ " ("
                                               ++ (if s > b
                                                   then "+"
                                                   else "")
                                               ++ (formatScore (testPrecision mainTest) (s-b))
                                               ++ ")."
                                               ++ " See " ++ submissionLink ++ "."
                                               ++ " :clap:")
                                msg chan message
                                case appNewBestResultSlackHook $ appSettings app of
                                  Just "" -> return ()
                                  Just hook -> liftIO $ runSlackHook hook message

                                  Nothing -> return ()
                             else return ()
                    [] -> return ()
            Nothing -> return ()
        Nothing -> return ()

      if appAutoOpening $ appSettings app
        then
          doMakePublic userId submissionId chan
        else
          return ()

      if not (null relevantIndicators)
        then
          checkIndicators user challengeId submissionId submissionLink relevantIndicators chan
        else
          return ()

    Nothing -> return ()

checkIndicators :: User -> ChallengeId -> SubmissionId -> Text -> [IndicatorEntry] -> Channel -> Handler ()
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan = do
  msg chan "Checking indicators..."
  theNow <- liftIO $ getCurrentTime
  mapM_ (\indicator -> checkIndicator theNow user challengeId submissionId submissionLink indicator chan) relevantIndicators

checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) id challengeId
  mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)

checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
checkTarget theNow user submissionLink entries indicator target chan = do
  app <- getYesod
  let status = getTargetStatus theNow entries indicator target
  if status == TargetPassed
    then
     do
      let message = "Congratulations!!! The target " ++ indicatorText
                     ++ " was beaten by "
                     ++ (fromMaybe "???" $ userName user)
                     ++ ", "
                     ++ " See " ++ submissionLink ++ "."
                     ++ (T.replicate 10 " :champagne: ") ++ " :mleczko: "
      msg chan message
      case appNewBestResultSlackHook $ appSettings app of
          Just "" -> return ()
          Just hook -> liftIO $ runSlackHook hook message
          Nothing -> return ()
    else
       return ()
  where indicatorText = prettyIndicatorEntry indicator

getScoreForOut :: (PersistQueryRead (YesodPersistBackend site), YesodPersist site, BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Test -> Out -> HandlerFor site (Maybe Double)
getScoreForOut mainTestId out = do
  mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
                                     EvaluationTest ==. mainTestId]
                                    []
  return $ case mEvaluation of
             Just evaluation -> evaluationScore $ entityVal evaluation
             Nothing -> Nothing

getSubmission :: UserId -> Maybe TeamId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
getSubmission userId mTeamId repoId commit challengeId subDescription chan = do
  challenge <- runDB $ get404 challengeId
  maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
  case maybeSubmission of
    Just (Entity submissionId _) -> do
      msg chan "Submission already there, re-checking"
      return submissionId
    Nothing -> do
      msg chan "Creating new submission"
      time <- liftIO getCurrentTime
      runDB $ insert $ Submission {
        submissionRepo=repoId,
        submissionCommit=commit,
        submissionChallenge=challengeId,
        submissionDescription=subDescription,
        submissionStamp=time,
        submissionSubmitter=userId,
        submissionIsPublic=False,
        submissionIsHidden=False,
        submissionVersion=challengeVersion challenge,
        submissionTeam=mTeamId }

getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan

checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
checkRepoAvailibility challengeId repoId chan = do
  maybeOtherChallengeId <- runDB $ selectFirst ( [ChallengePublicRepo ==. repoId]
                                                 ||. [ChallengePrivateRepo ==. repoId]) []
  case maybeOtherChallengeId of
    Just _ -> do
      err chan "Repository already used as a challenge repo, please use a different repo or a different branch"
      return False
    Nothing -> do
      maybeOtherSubmissionId <- runDB $ selectFirst [SubmissionRepo ==. repoId,
                                                    SubmissionChallenge !=. challengeId] []
      case maybeOtherSubmissionId of
        Just _ -> do
          err chan "Repository already used as a submission repo for a different challenge, please use a different repo or a different branch"
          return False
        Nothing -> return True

challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App ()
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")

data ChallengeSubmissionData = ChallengeSubmissionData {
  challengeSubmissionDataDescription :: Maybe Text,
  challengeSubmissionDataTags :: Maybe Text,
  challengeSubmissionDataRepo :: RepoSpec,
  challengeSubmissionDataTeam :: Maybe TeamId }


fetchUserTeams :: (YesodPersist site, BackendCompatible SqlBackend (YesodPersistBackend site), PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site)) => Key User -> HandlerFor site [Entity Team]
fetchUserTeams userId = runDB $ E.select $ E.from $ \(team, teamMember) -> do
                                E.where_ (teamMember ^. TeamMemberTeam E.==. team ^. TeamId
                                          E.&&. teamMember ^. TeamMemberUser E.==. E.val userId)
                                E.orderBy [E.desc (teamMember ^. TeamMemberIsCaptain), E.asc (team ^. TeamIdent)]
                                return team

fetchDefaultTeam :: Key User -> HandlerFor App (Maybe (Key Team))
fetchDefaultTeam userId = do
  myTeams <- fetchUserTeams userId
  app <- getYesod
  let autoTeam = appAutoTeam $ appSettings app
  if autoTeam
    then
      return $ entityKey <$> listToMaybe myTeams
    else
      return Nothing


submissionForm :: UserId -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe (Maybe TeamId) -> Form ChallengeSubmissionData
submissionForm userId defaultUrl defBranch defaultGitAnnexRemote defaultTeam = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
    <$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
    <*> aopt textField (tagsfs MsgSubmissionTags) Nothing
    <*> (RepoSpec <$> areq textField (bfs MsgSubmissionUrl) defaultUrl
                  <*> areq textField (bfs MsgSubmissionBranch) defBranch
                  <*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
    <*> aopt (selectField teams) (bfs MsgAsTeam) defaultTeam
    where teams = do
            myTeams <- fetchUserTeams userId
            optionsPairs $ map (\t -> (teamIdent $ entityVal t, entityKey t)) myTeams


getUserInfoR :: Handler Value
getUserInfoR = do
  (Entity _ user) <- requireAuthPossiblyByToken
  return $ String $ userIdent user

getAddUserR :: Handler Value
getAddUserR = do
  mInfo <- authorizationTokenAuth
  case mInfo of
    Just infos -> do
      let ident = jwtAuthInfoIdent infos
      x <- runDB $ getBy $ UniqueUser ident
      case x of
        Just _ -> return $ Bool False
        Nothing -> do
          -- family or given name can be used for a team name
          -- (as an ugly work-around...), hence we look at TEAM_FIELD and when
          -- it is set to "given_name" or "family_name" it is not
          -- considered a part of the user's
          -- name

          app <- getYesod
          let teamField = appTeamField $ appSettings app

          let uname = intercalate " " $ catMaybes (
                [if teamField /= (Just "given_name")
                 then jwtAuthInfoGivenName infos
                 else Nothing,
                 if teamField /= (Just "family_name")
                 then jwtAuthInfoFamilyName infos
                 else Nothing])


          let mUName = if (null uname)
                      then Nothing
                      else (Just uname)

          userId <- runDB $ insert User
            { userIdent = ident
            , userPassword = Nothing
            , userName = mUName
            , userIsAdmin = False
            , userLocalId = Nothing
            , userIsAnonymous = False
            , userAvatar = Nothing
            , userVerificationKey = Nothing
            , userKeyExpirationDate = Nothing
            , userTriggerToken = Nothing
            , userAltRepoScheme = Nothing
            }

          case teamField of
            Just teamFieldName -> do
              case jwtAuthInfoCustomField teamFieldName infos of
                Just team -> do
                  t <- runDB $ getBy $ UniqueTeam team
                  (teamId, isCaptain) <- case t of
                    Just (Entity existingTeamId _) -> return (existingTeamId, False)
                    Nothing -> do
                      newTeamId <- runDB $ insert $ Team {teamIdent = team,
                                                         teamAvatar = Nothing}
                      return (newTeamId, True)
                  runDB $ addMemberToTeam userId teamId isCaptain
                  return ()
                Nothing -> return ()
            Nothing -> return ()

          return $ Bool True
    Nothing -> return $ Bool False

addUserApi :: Swagger
addUserApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareAddUserApi mempty

declareAddUserApi :: Declare (Definitions Schema) Swagger
declareAddUserApi = do
  -- param schemas
  response <- declareResponse (Proxy :: Proxy Bool)

  return $ mempty
    & paths .~
        fromList [ ("/api/add-user",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ ]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ "Creates a new user"
                                        & at 200 ?~ Inline response))
                 ]


userInfoApi :: Swagger
userInfoApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareUserInfoApi mempty

declareUserInfoApi :: Declare (Definitions Schema) Swagger
declareUserInfoApi = do
  -- param schemas
  response <- declareResponse (Proxy :: Proxy String)

  return $ mempty
    & paths .~
        fromList [ ("/api/user-info",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ ]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ "Returns the identifier of the user"
                                        & at 200 ?~ Inline response))
                 ]



declareAllSubmissionsApi :: String -> String -> Declare (Definitions Schema) Swagger
declareAllSubmissionsApi q d = do
  -- param schemas
  let challengeNameSchema = toParamSchema (Proxy :: Proxy String)

  allSubmissionsResponse <- declareResponse (Proxy :: Proxy SubmissionsView)

  return $ mempty
    & paths .~
        fromList [ ("/api/" ++ q ++ "/{challengeName}",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ Inline $ mempty
                                                          & name .~ "challengeName"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ challengeNameSchema) ]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ T.pack d
                                        & at 200 ?~ Inline allSubmissionsResponse))
                 ]


allSubmissionsApi :: Swagger
allSubmissionsApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-all-submissions" "Returns all submissions for a challenge") mempty

mySubmissionsApi :: Swagger
mySubmissionsApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-my-submissions" "Returns all submissions for a challenge for the user") mempty

getChallengeAllSubmissionsJsonR :: Text -> Handler Value
getChallengeAllSubmissionsJsonR challengeName = do
  v <- fetchAllSubmissionsView challengeName
  return $ toJSON v

getChallengeMySubmissionsJsonR :: Text -> Handler Value
getChallengeMySubmissionsJsonR challengeName = do
  v <- fetchMySubmissionsView challengeName
  return $ toJSON v

fetchAllSubmissionsView :: Text -> Handler SubmissionsView
fetchAllSubmissionsView challengeName = do
  fetchChallengeSubmissionsView (const True) challengeName

fetchMySubmissionsView :: Text -> Handler SubmissionsView
fetchMySubmissionsView challengeName = do
  Entity userId _ <- requireAuthPossiblyByToken
  fetchChallengeSubmissionsView (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName

convertTagInfoToView :: (Entity Import.Tag, Entity SubmissionTag) -> TagView
convertTagInfoToView tagInfo =
  TagView {
     tagViewName = tagName $ entityVal $ fst tagInfo,
     tagViewDescription = tagDescription $ entityVal $ fst tagInfo,
     tagViewAccepted = submissionTagAccepted $ entityVal $ snd tagInfo
     }

convertEvaluationToView :: Map TestReference Evaluation -> Entity Test -> Maybe EvaluationView
convertEvaluationToView theMapping entTest =
  case join $ evaluationScore <$> mEvaluation of
    Just s ->
      Just $ EvaluationView {
        evaluationViewScore = formatTruncatedScore formattingOps mEvaluation,
        evaluationViewFullScore = s,
        evaluationViewTest = testRef
        }
    Nothing -> Nothing
  where mEvaluation = Map.lookup testRef theMapping
        formattingOps = getTestFormattingOpts $ entityVal entTest
        testRef = getTestReference entTest

-- convertTableEntryToView :: Maybe UserId -> [Entity Test] -> TableEntry -> SubmissionView
convertTableEntryToView :: [Entity Test] -> TableEntry -> HandlerFor App SubmissionView
convertTableEntryToView tests entry = do
  mUserId <- maybeAuthPossiblyByToken

  isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission entry
  isVisible <- runDB $ checkWhetherVisible submission (entityKey <$> mUserId)

  return $ SubmissionView {
    submissionViewId = fromSqlKey $ entityKey $ tableEntrySubmission entry,
    submissionViewVariantId = fromSqlKey $ entityKey $ tableEntryVariant entry,
    submissionViewRank = tableEntryRank entry,
    submissionViewSubmitter = formatSubmitter $ entityVal $ tableEntrySubmitter entry,
    submissionViewWhen = submissionStamp submission,
    submissionViewVersion = tableEntryVersion entry,
    submissionViewDescription = descriptionToBeShown submission
                                                     (entityVal $ tableEntryVariant entry)
                                                     (map entityVal $ tableEntryParams entry),
    submissionViewTags = Import.map convertTagInfoToView $ tableEntryTagsInfo entry,
    submissionViewHash = fromSHA1ToText $ submissionCommit submission,
    submissionViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
    submissionViewIsOwner = (entityKey <$> mUserId) == Just (submissionSubmitter submission),
    submissionViewIsReevaluable = isReevaluable,
    submissionViewIsVisible = isVisible,
    submissionViewIsPublic = submissionIsPublic submission,
    submissionViewTeam = teamIdent <$> entityVal <$> tableEntryTeam entry
  }
  where submission = entityVal $ tableEntrySubmission entry

fetchChallengeSubmissionsView :: ((Entity Submission) -> Bool) -> Text -> Handler SubmissionsView
fetchChallengeSubmissionsView condition challengeName = do
  Entity challengeId _ <- runDB $ getBy404 $ UniqueName challengeName
  (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
  let tests = sortBy testComparator tests'

  submissions <- mapM (convertTableEntryToView tests) evaluationMaps

  return $ SubmissionsView {
    submissionsViewSubmissions = submissions,
    submissionsViewTests = map getTestReference tests
  }


-- TODO switch to fetchChallengeSubmissionSview
getChallengeMySubmissionsR :: Text -> Handler Html
getChallengeMySubmissionsR challengeName = do
  userId <- requireAuthId
  getChallengeSubmissions (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName

getChallengeAllSubmissionsR :: Text -> Handler Html
getChallengeAllSubmissionsR challengeName = getChallengeSubmissions (\_ -> True) challengeName

data EvaluationView = EvaluationView {
  evaluationViewScore :: Text,
  evaluationViewFullScore :: Double,
  evaluationViewTest :: TestReference
}

instance ToJSON EvaluationView where
    toJSON e = object
        [ "score" .= evaluationViewScore e
        , "full-score" .= evaluationViewFullScore e
        , "test" .= evaluationViewTest e
        ]

instance ToSchema EvaluationView where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
    doubleSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Double)
    testRefSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy TestReference)
    return $ NamedSchema (Just "Evaluation") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [  ("score", stringSchema)
                     , ("full-score", doubleSchema)
                     , ("test", testRefSchema)
                    ]
        & required .~ [ "score", "full-score", "test" ]


data TagView = TagView {
  tagViewName :: Text,
  tagViewDescription :: Maybe Text,
  tagViewAccepted :: Maybe Bool }

instance ToJSON TagView where
  toJSON t = object
       [ "name" .= tagViewName t
       , "description" .= tagViewDescription t
       , "accepted" .= tagViewAccepted t
       ]

instance ToSchema TagView where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
    boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
    return $ NamedSchema (Just "TagView") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [  ("name", stringSchema)
                     , ("description", stringSchema)
                     , ("accepted", boolSchema)
                    ]
        & required .~ [ "name", "description" ]


data SubmissionView = SubmissionView {
  submissionViewId :: Int64,
  submissionViewVariantId :: Int64,
  submissionViewRank :: Int,
  submissionViewSubmitter :: Text,
  submissionViewWhen :: UTCTime,
  submissionViewVersion :: (Int, Int, Int),
  submissionViewDescription :: Text,
  submissionViewTags :: [TagView],
  submissionViewHash :: Text,
  submissionViewEvaluations :: [EvaluationView],
  submissionViewIsOwner :: Bool,
  submissionViewIsReevaluable :: Bool,
  submissionViewIsVisible :: Bool,
  submissionViewIsPublic :: Bool,
  submissionViewTeam :: Maybe Text
}

instance ToJSON SubmissionView where
  toJSON s = object
   ["id" .= submissionViewId s
    , "variant" .= submissionViewVariantId s
    , "rank" .= submissionViewRank s
    , "submitter" .= submissionViewSubmitter s
    , "when" .= submissionViewWhen s
    , "version" .= submissionViewVersion s
    , "description" .= submissionViewDescription s
    , "tags" .= submissionViewTags s
    , "hash" .= submissionViewHash s
    , "evaluations" .= submissionViewEvaluations s
    , "isOwner" .= submissionViewIsOwner s
    , "isReevaluable" .= submissionViewIsReevaluable s
    , "isVisible" .= submissionViewIsVisible s
    , "isPublic" .= submissionViewIsPublic s
    , "team" .= submissionViewTeam s
    ]

instance ToSchema SubmissionView where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
    boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
    intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
    tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView])
    evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
    return $ NamedSchema (Just "SubmissionView") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [  ("id", submissionIdSchema)
                     , ("variant", variantIdSchema)
                     , ("rank", intSchema)
                     , ("submitter", submitterSchema)
                     , ("when", stringSchema)
                     , ("version", versionSchema)
                     , ("description", stringSchema)
                     , ("tags", tagsSchema)
                     , ("hash", hashSchema)
                     , ("evaluations", evalsSchema)
                     , ("isOwner", boolSchema)
                     , ("isReevaluable", boolSchema)
                     , ("isVisible", isVisibleSchema)
                     , ("isPublic", isPublicSchema)
                     , ("team", stringSchema)
                    ]
        & required .~ [ "id", "variant", "rank", "submitter", "when", "version",
                        "description", "tags", "hash", "evaluations",
                        "isOwner", "isReevaluable", "isVisible", "isPublic" ]

data SubmissionsView = SubmissionsView {
  submissionsViewSubmissions :: [SubmissionView],
  submissionsViewTests :: [TestReference]
}

instance ToJSON SubmissionsView where
  toJSON ss = object
    [ "tests" .= submissionsViewTests ss,
      "submissions" .= submissionsViewSubmissions ss
    ]

instance ToSchema SubmissionsView where
  declareNamedSchema _ = do
    submissionViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [SubmissionView])
    testRefsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
    return $ NamedSchema (Just "SubmissionsView") $ mempty
        & type_ .~ SwaggerObject
        & properties .~
           fromList [  ("submissions", submissionViewsSchema)
                     , ("tests", testRefsSchema)
                    ]
        & required .~ [ "tests", "submission" ]

getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
getChallengeSubmissions condition challengeName = do
  Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
  (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
  let tests = sortBy testComparator tests'
  mauth <- maybeAuth
  let muserId = (\(Entity uid _) -> uid) <$> mauth

  app <- getYesod
  let scheme = appRepoScheme $ appSettings app

  challengeRepo <- runDB $ get404 $ challengePublicRepo challenge

  let params = getNumericalParams evaluationMaps

  challengeLayout True challenge (challengeAllSubmissionsWidget muserId
                                                                challenge
                                                                scheme
                                                                challengeRepo
                                                                evaluationMaps
                                                                tests
                                                                params)

getNumericalParams :: [TableEntry] -> [Text]
getNumericalParams entries = filter (isNumericalParam entries) $ getAllParams entries

isNumericalParam :: [TableEntry] -> Text -> Bool
isNumericalParam entries param =
  all doesTextRepresentNumber
  $ concat
  $ map ((map parameterValue)
       . (filter (\p -> parameterName p == param))
       . (map entityVal)
       . tableEntryParams) entries

doesTextRepresentNumber :: Text -> Bool
doesTextRepresentNumber t = isJust $ ((TR.readMaybe $ T.unpack t) :: Maybe Double)

getAllParams :: [TableEntry] -> [Text]
getAllParams entries = sort
               $ nub
               $ concat
               $ map (\entry -> map (parameterName . entityVal) (tableEntryParams entry)) entries


challengeAllSubmissionsWidget :: Maybe UserId
                                -> Challenge
                                -> RepoScheme
                                -> Repo
                                -> [TableEntry]
                                -> [Entity Test]
                                -> [Text]
                                -> WidgetFor App ()
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests params =
  $(widgetFile "challenge-all-submissions")
  where delta = Number 4
        higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests

paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App ()
paramGraphsWidget challenge tests params = $(widgetFile "param-graphs")
  where chartJSs = getChartJss challenge selectedTests params
        selectedTests = reverse $ getMainTests tests

getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
getChartJss challenge tests params =
  mconcat $ [(getChartJs challenge test param) | test <- tests, param <- params]

getChartJs :: Challenge
             -> Entity Test
             -> Text
             -> JavascriptUrl (Route App)
getChartJs challenge (Entity testId test) param = [julius|
$.getJSON("@{ChallengeParamGraphDataR (challengeName challenge) testId param}", function(data) {
        c3.generate({
                bindto: '#chart-' + #{toJSON param} + '-' + #{toJSON testId},
                data: data,
                axis: {
                   x: {
                     label: #{toJSON param},
                   },
                   y: {
                     label: #{toJSON testFormatted},
                   }
                }
    }) });
|]
   where testFormatted = formatTest test


challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
challengeLayout withHeader challenge widget = do
  tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
  theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
  let versionFormatted = formatVersion ((versionMajor $ entityVal theVersion),
                                        (versionMinor $ entityVal theVersion),
                                        (versionPatch $ entityVal theVersion))
  maybeUser <- maybeAuth
  bc <- widgetToPageContent widget
  defaultLayout $ do
    setTitle "Challenge"
    $(widgetFile "challenge")

getTestProgressR :: Int -> Int -> Handler TypedContent
getTestProgressR m d = runViewProgress $ doTestProgress m d

getTestProgressJsonR :: Int -> Int -> Handler Value
getTestProgressJsonR m d = do
  _ <- requireAuthPossiblyByToken
  runViewProgressAsynchronously $ doTestProgress m d

declareTestProgressSwagger :: Declare (Definitions Schema) Swagger
declareTestProgressSwagger = do
  -- param schemas
  let numberSchema = toParamSchema (Proxy :: Proxy Int)

  numberResponse      <- declareResponse (Proxy :: Proxy Int)

  return $ mempty
    & paths .~
        fromList [ ("/api/test-progress/{num}/{delay}",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ Inline $ mempty
                                                          & name .~ "num"
                                                          & description ?~ "The number up to which to count"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ numberSchema),
                                                          Inline $ mempty
                                                          & name .~ "delay"
                                                          & description ?~ "Delay in seconds"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ numberSchema)
                                                          ]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ "Counts up to a given number, returns an ID of an asynchronous job. This is just a sample end-point for testing logging of asynchronous jobs."
                                        & at 200 ?~ Inline numberResponse))
                 ]

testProgressApi :: Swagger
testProgressApi = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareTestProgressSwagger mempty


doTestProgress :: Int -> Int -> Channel -> Handler ()
doTestProgress m d chan = do
  _ <- forM [1..m] $ (\i -> do
                       msg chan $ (Data.Text.pack $ ("GO\n" ++ show i))
                       liftIO $ threadDelay (d * 1000000)
                       return ())
  return ()


declareViewProgressWithWebSocketsSwagger :: Declare (Definitions Schema) Swagger
declareViewProgressWithWebSocketsSwagger = do
  -- param schemas
  let numberSchema = toParamSchema (Proxy :: Proxy Int)

  numberResponse      <- declareResponse (Proxy :: Proxy Int)

  return $ mempty
    & paths .~
        fromList [ ("/api/view-progress-with-web-sockets/{jobId}",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ Inline $ mempty
                                                          & name .~ "jobId"
                                                          & description ?~ "The ID for the job to be shown"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ numberSchema)]
                                        & produces ?~ MimeList ["application/json"]
                                        & description ?~ "Initiates a web socket communication with which progress logs can be read. Returns just the Job ID (the same number as the parameter)"
                                        & at 200 ?~ Inline numberResponse))
                 ]

viewProgressWithWebSockets :: Swagger
viewProgressWithWebSockets = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareViewProgressWithWebSocketsSwagger mempty


declareViewProgressLogSwagger :: Declare (Definitions Schema) Swagger
declareViewProgressLogSwagger = do
  let numberSchema = toParamSchema (Proxy :: Proxy Int)

  numberResponse      <- declareResponse (Proxy :: Proxy Int)

  return $ mempty
    & paths .~
        fromList [ ("/api/view-progress-log/{jobId}",
                    mempty & DS.get ?~ (mempty
                                        & parameters .~ [ Inline $ mempty
                                                          & name .~ "jobId"
                                                          & description ?~ "The ID for the job to be shown"
                                                          & required ?~ True
                                                          & schema .~ ParamOther (mempty
                                                                                  & in_ .~ ParamPath
                                                                                  & paramSchema .~ numberSchema)]
                                        & produces ?~ MimeList ["text/html"]
                                        & description ?~ "Returns HTML code with embedded JS script for showing logs via web sockets"
                                        & at 200 ?~ Inline numberResponse))
                 ]

viewProgressLog :: Swagger
viewProgressLog = spec & definitions .~ defs
  where
    (defs, spec) = runDeclare declareViewProgressLogSwagger mempty