Handler.hs

{-# LANGUAGE OverloadedStrings #-}
{-|
Module       : Control.HannahCI.Handler
Description  : Retrieves log information and processes update
Copyright    : (c) Philip Woods 2015
License      : AGPL-3
Maintainer   : elzairthesorcerer@gmail.com
Stability    : experimental
Portabiltity : Linux
-}

module Control.HannahCI.Handler (
  getAllRepos,
  processUpdate
) where

import Control.Monad                (liftM)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List                    (zip)
import qualified Data.Text as DT
import Data.Info                    (ProjectInfo(..), HostInfo(..),
                                     LogInfo(..), pathRoot, tPathRoot)
import System.Posix.Console.Command (Command, runCommands)
import System.Posix.IO.Log          (getCurrentLog, writeLog)
import Text.JSON.WebHooks.Bitbucket (parseHook)
import Text.YAML.Config             (readConfig)

-- | Retrieve the latest log files for all projects
getAllRepos :: IO (Either String [LogInfo])   -- ^ Success: List of logs; 
                                              --   Failure: Error 
getAllRepos = do
  conf <- readConfig
  case conf of
    Left err   -> return $ Left err
    Right info -> liftM Right $ sequence $ fmap getCurrentLog info

-- | Process Webhook Update
processUpdate :: BS.ByteString                -- ^ Contents of hook
              -> IO ()                  -- ^ No return value
processUpdate body = do
  hook <- return $ parseHook body
  conf <- readConfig
  case conf of
    Left err   -> return ()
    Right info -> do
      repos <- return $ filterRepos info hook
      runAllRepoCommands repos
  where runAllRepoCommands [] = return ()
        runAllCommands (repo:rest) = do
          runAllRepoCommands rest
        runRepoCommands repo = do
          result <- runCommands $ makeCommandsWithCwd repo
          case result of
            Nothing  -> return ()
            Just err -> do writeLog repo (DT.pack err)
        filterRepos info hook = filter (\x -> x `elem` hook) info

-- | Create pair of command text and working directory
makeCommandsWithCwd :: ProjectInfo            -- ^ Given project
                    -> [Command]              -- ^ List of commands
makeCommandsWithCwd info =
  zip (getCommands info) (repeat (getCwd info))
  where getCommands i = map DT.unpack $ makeCommands i
        getCwd      j = pathRoot ++ "projects/" ++
                        (DT.unpack (provider j)) ++
                        "/" ++ (DT.unpack (repository j))

-- | Create the commands that are executed on every application host
makeDefaultHostCommands :: DT.Text            -- ^ Repository name
                        -> DT.Text            -- ^ Host name
                        -> [DT.Text]          -- ^ List of command strings
makeDefaultHostCommands repo name = map DT.concat 
   [["scp ", tPathRoot, "local-images/", DT.replace "/" "_" repo, ".tar hannahci@", name, ":/home/hannahci/remote-images/", DT.replace "/" "_" repo, ".tar"],
    ["ssh hannahci@", name, " docker load -i /home/hannahci/remote-images/", DT.replace "/" "_" repo, ".tar"],
    ["ssh hannahci@", name, " docker kill ", repo]]

-- | Create the commands executed on application hosts
makeHostCommands :: DT.Text                   -- ^ Repository name
                 -> HostInfo                  -- ^ Host information
                 -> [DT.Text]                 -- ^ List of command strings
makeHostCommands repo HostInfo{hostName = name, runOptions = Just opts} =
  (makeDefaultHostCommands repo name) ++
  [DT.concat ["ssh hannahci@", name, " docker run -d ", opts, " --name ", repo, " ", repo]]
makeHostCommands repo HostInfo{hostName = name, runOptions = Nothing} =
  (makeDefaultHostCommands repo name) ++
  [DT.concat ["ssh hannahci@", name, " docker run -d --name ", repo, " ", repo]]

-- | Create the commands that will be executed for every project
makeDefaultCommands :: DT.Text                -- ^ Branch name
                    -> [DT.Text]              -- ^ List of command strings
makeDefaultCommands br = map DT.concat
  [["git fetch origin"],
   ["git checkout ", br],
   ["git merge origin/", br, " -X theirs"]]

-- | Create the commands to execute for a given project
makeCommands :: ProjectInfo                   -- ^ Given project
             -> [DT.Text]                     -- ^ List of command strings
makeCommands ProjectInfo{provider = _, repository = r, branch = b, preCommands = Just pc, hostInfo = Just h} =
 (makeDefaultCommands b) ++ pc ++
 (map DT.concat
  [["docker build -t=", r, " ."],
   ["docker save -o ", tPathRoot, "local-images/", DT.replace "/" "_" r, ".tar ", r]]) ++
 (concatMap (makeHostCommands r) h)
makeCommands ProjectInfo{provider = _, repository = r, branch = b, preCommands = Nothing, hostInfo = Just h} =
 (makeDefaultCommands b) ++ 
 (map DT.concat
  [["docker build -t=", r, " ."],
   ["docker save -o ", tPathRoot, "local-images/", DT.replace "/" "_" r, ".tar ", r]]) ++
 (concatMap (makeHostCommands r) h)
makeCommands ProjectInfo{provider = _, repository = r, branch = b, preCommands = Just pc, hostInfo = Nothing} =
 (makeDefaultCommands b) ++ pc ++
 (map DT.concat
  [["docker build -t=", r, " ."],
   ["docker save -o ", tPathRoot, "local-images/", DT.replace "/" "_" r, ".tar ", r]])
makeCommands ProjectInfo{provider = _, repository = r, branch = b, preCommands = Nothing, hostInfo = Nothing} =
 (makeDefaultCommands b) ++
 (map DT.concat
  [["docker build -t=", r, " ."],
   ["docker save -o ", tPathRoot, "local-images/", DT.replace "/" "_" r, ".tar ", r]])