MicroCI.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import Paths_micro_ci
import qualified Config
import Config (Config)
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TQueue
import Control.Exception (try)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson (FromJSON(..), withArray, eitherDecodeStrict)
import Data.Foldable
import Data.List
import Data.Maybe
import Data.Monoid
import Data.String
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as LT
import qualified Dhall
import GitHub.Data
import GitHub.Endpoints.Repos.Status
import Network.Wai.Handler.Warp as Warp
import Servant
import Servant.GitHub.Webhook
import Servant.Server
import System.Directory
import System.Exit
import System.FilePath
import System.Process
import qualified System.Process as Process


-- Job

data Job = Job
  { jobRepo :: Repo
  , jobCommit :: Text.Text
  , jobAttr :: AttrPath
  }


doJob :: Config -> Job -> IO ()
doJob config job = do
  ensureRepository config (jobRepo job)

  checkoutRef config (jobRepo job) (jobCommit job)

  buildRes <-
    buildAttribute config (jobRepo job) (jobAttr job)

  createStatus
    (OAuth (fromString $ LT.unpack $ Config.oauth config))
    (simpleOwnerLogin $ repoOwner (jobRepo job))
    (repoName (jobRepo job))
    (mkName (Proxy @Commit)
            (jobCommit job))
    NewStatus { newStatusState =
                  if buildSuccess buildRes then
                    Success
                  else
                    Failure
              , newStatusTargetUrl =
                  Just $ URL $ Text.pack $
                  LT.unpack (Config.httpRoot config) ++ "/" ++ takeFileName (buildDerivation buildRes)
              , newStatusDescription =
                  Just $
                  if buildSuccess buildRes then
                    "nix-build successful"
                  else
                    "nix-build failed"
              , newStatusContext =
                  "ci.nix: " <> fromString (encodeAttrPath (jobAttr job))
              }

  return ()


-- buildAttribute

data BuildResult = BuildResult
  { buildSuccess :: Bool
  , buildDerivation :: String
  }


buildAttribute :: Config -> Repo -> AttrPath -> IO BuildResult
buildAttribute config repo path = do
  (exitCode, stdout, stderr) <-
    readCreateProcessWithExitCode
      (inGitRepository config repo
         (Process.proc "nix-instantiate"
            ["ci.nix"
            , "-A"
            , encodeAttrPath path
            ]))
      ""

  drv <-
    case lines stdout of
      [drv] ->
        return drv

      _ ->
        fail $ unlines $
        [ "Colud not find .drv from nix-instantiate ci.nix:"
        , ""
        , stdout
        , stderr
        ]
  
  (exitCode, stdout, stderr) <-
    readCreateProcessWithExitCode
      (inGitRepository config repo
         (Process.proc "nix-store" [ "--realise", drv ]))
      ""

  createDirectoryIfMissing
    True
    (LT.unpack $ Config.logs config)

  writeFile (LT.unpack (Config.logs config) </> takeFileName drv <.> "stdout") stdout

  writeFile (LT.unpack (Config.logs config) </> takeFileName drv <.> "stderr") stderr

  return BuildResult
    { buildSuccess =
        case exitCode of
          ExitSuccess ->
            True

          ExitFailure{} ->
            False
    , buildDerivation = drv
    }

    


-- findJobAttrPaths


findJobAttrPaths :: Config -> Repo -> IO [AttrPath]
findJobAttrPaths config repo = do
  jobsNixPath <-
    getDataFileName "jobs.nix"
    
  (exitCode, jobs, stderr) <-
    readCreateProcessWithExitCode
      (inGitRepository config repo
         (Process.proc
            "nix-instantiate"
            [ "--eval"
            , "--strict"
            , "--json"
            , "-E"
            , "import " ++ jobsNixPath ++ " (import ./ci.nix)"
            ]))
      ""

  unless (exitCode == ExitSuccess) $
    fail $ unlines
      [ "Could not identify jobs in ci.nix:"
      , ""
      , stderr
      ]

  case eitherDecodeStrict (fromString jobs) of
    Left e ->
      fail $ unlines $
        [ "Could not parse jobs JSON"
        , ""
        , "Aeson reported:"
        , ""
        , show e
        , ""
        , "I'm trying to parse:"
        , ""
        , jobs
        ] 

    Right paths ->
      return paths


  
-- repoDir


repoDir :: Config -> Repo -> FilePath
repoDir config repo =
  LT.unpack (Config.repoRoot config)
    </> Text.unpack (untagName (simpleOwnerLogin (repoOwner repo)))
    </> Text.unpack (untagName (repoName repo))



-- ensureRepository

-- | Ensure that a repository has been cloned into the repoRoot directory, and that
-- it is up-to-date.

ensureRepository :: Config -> Repo -> IO ()
ensureRepository cfg repo = do 
  let
    dir =
      repoDir cfg repo
  
  exists <-
    doesDirectoryExist dir

  if exists then 
    void $
      readCreateProcess
        (inGitRepository cfg repo 
           (proc "git" [ "fetch" ]))
        ""
  else do 
    URL cloneUrl <-
      maybe
        (fail (Text.unpack (untagName (repoName repo)) ++ " does not have a clone URL."))
        return
        (repoCloneUrl repo)

    void $ readCreateProcess (proc "git" [ "clone", Text.unpack cloneUrl, dir ]) ""



checkoutRef :: Config -> Repo -> Text.Text -> IO ()
checkoutRef config repo ref =
  void $
    readCreateProcess
      (inGitRepository config repo 
         (proc "git" [ "checkout", Text.unpack ref ]))
      ""


-- inGitRepository


inGitRepository :: Config -> Repo -> CreateProcess -> CreateProcess
inGitRepository config repo a =
  a { cwd = Just (repoDir config repo) }



-- HttpApi
  

type HttpApi =
  "github"
    :> "web-hook"
    :> GitHubEvent '[ 'WebhookPullRequestEvent ]
    :> GitHubSignedReqBody '[JSON] PullRequestEvent
    :> Post '[JSON] ()
  :<|>
  Capture "drv" Text.Text
    :> Get '[PlainText] Text.Text


httpEndpoints :: TQueue PullRequestCommit -> Config -> Server HttpApi
httpEndpoints q config =
  gitHubWebHookHandler q :<|> detailsHandler config


  
-- detailsHandler


detailsHandler :: Config-> Text.Text -> Handler Text.Text
detailsHandler config drvName = do
  stdout <-
    liftIO
      $ readFile (LT.unpack (Config.logs config) </> Text.unpack drvName <.> "stdout")

  stderr <-
    liftIO
      $ readFile (LT.unpack (Config.logs config) </> Text.unpack drvName <.> "stderr")

  return (Text.pack $ unlines [ stdout, "", stderr ])



-- AttrPath
  

-- | An attribute path.
newtype AttrPath =
  AttrPath [String]
  deriving (FromJSON)


encodeAttrPath :: AttrPath -> String
encodeAttrPath (AttrPath parts) =
  intercalate "." parts


-- gitHubWebHookHandler


-- | Top-level GitHub web hook handler. Ensures that a build is scheduled.

gitHubWebHookHandler :: TQueue PullRequestCommit -> RepoWebhookEvent -> ((), PullRequestEvent) -> Handler ()
gitHubWebHookHandler queue WebhookPullRequestEvent ((), ev) = do
  liftIO $ atomically $
    writeTQueue queue (pullRequestHead $ pullRequestEventPullRequest ev)

gitHubWebHookHandler _ _ _ =
  return ()



-- processPullRequest


processPullRequest :: Config -> TQueue Job -> PullRequestCommit ->  IO ()
processPullRequest config jobQueue pr = do
  let
    headRepo =
      pullRequestCommitRepo pr

  ensureRepository config headRepo

  checkoutRef config headRepo (pullRequestCommitSha pr)

  paths <-
    findJobAttrPaths config headRepo

  for_ paths $ \path ->
    atomically $
    writeTQueue
      jobQueue
      Job
        { jobRepo = headRepo
        , jobCommit = pullRequestCommitSha pr
        , jobAttr = path
        }



-- main


main :: IO ()
main = do
  config <-
    LT.readFile "config.dhall"
      >>= Dhall.input Dhall.auto
  
  jobQueue <-
    newTQueueIO

  prQueue <-
    newTQueueIO

  forkIO $ forever $ do
    job <-
      atomically $ fmap Left (readTQueue prQueue) <|> fmap Right (readTQueue jobQueue)

    --try $
    case job of
        Left pr ->
          processPullRequest config jobQueue pr

        Right job ->
          doJob config job
  
  Warp.run 8080
    (serveWithContext
       (Proxy @HttpApi)
       (gitHubKey (return (fromString $ LT.unpack $ Config.secret config)) :. EmptyContext)
       (httpEndpoints prQueue config))