Status.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Cmd.Status (
  statusCmd,
  unpushedCmd
  )
where

import Common
import Common.System

import Data.Fixed
import Data.Time.Clock
import Data.Time.LocalTime
import Fedora.Bodhi

import Bugzilla
import Branches
import Git
import Koji
import ListReviews
import Package

-- FIXME instead --pull?
-- FIXME --pending
-- FIXME handle not cloned (remote only)
-- FIXME silence fetching of new branches? (for --reviews etc)
statusCmd :: Bool -> Bool -> (BranchesReq,[String]) -> IO ()
statusCmd nofetch reviews (breq, pkgs) = do
  reviewpkgs <-
    if reviews
    then map reviewBugToPackage <$> listReviewsAll True ReviewRepoCreated
    else return []
  -- FIXME dirty not okay for multiple branches?
  withPackagesByBranches HeaderMay False (if nofetch then dirtyGit else dirtyGitFetch) AnyNumber statusBranch (breq, pkgs ++ reviewpkgs)
  where
    -- FIXME note dirty when local changes
    statusBranch :: Package -> AnyBranch -> IO ()
    statusBranch _ (OtherBranch _) =
      error' "status currently only defined for release branches"
    statusBranch pkg rbr@(RelBranch br) = do
      brExists <- checkIfRemoteBranchExists rbr
      if not brExists
        then do
        name <- getDirectoryName
        putStrLn $ name +-+ "has no branch" +-+ show br
        else do
        gitSwitchBranch rbr
        let spec = packageSpec pkg
        ifM (notM (doesFileExist spec))
          (ifM initialPkgRepo
            (putStrLn $ show br ++ ": initial repo")
            (putStrLn $ "missing" +-+ spec)) $
          do
          mnvr <- pkgNameVerRel br spec
          case mnvr of
            Nothing -> do
              putStrLn "undefined NVR!\n"
              putStr "HEAD "
              whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit
            Just nvr -> do
              -- unless (br == Rawhide) $ do
              --   newerBr <- newerBranch br <$> getFedoraBranches
              --   ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", show newerBr]
              --   when ancestor $ do
              --     unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr
              --     unless (null unmerged) $ do
              --       putStrLn $ "Newer commits in" +-+ show newerBr ++ ":"
              --       mapM_ putStrLn unmerged
              munpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"
              case munpushed of
                Nothing -> do
                  mbuild <- kojiGetBuildID fedoraHub nvr
                  case mbuild of
                    Nothing -> do
                      mlatest <- kojiLatestNVR (branchDestTag br) (unPackage pkg)
                      case mlatest of
                        Nothing -> putStrLn $ "new" +-+ nvr
                        Just latest ->
                          putStrLn $ if equivNVR nvr latest then latest +-+ "is latest modulo disttag" else (if null latest then "new " else (head . words) latest +-+ "->\n") ++ nvr
                    Just buildid -> do
                      tags <- kojiBuildTags fedoraHub (buildIDInfo buildid)
                      if null tags
                        then do
                        mstatus <- kojiBuildStatus nvr
                        -- FIXME show pending archs building
                        whenJust mstatus $ \ status ->
                          -- FIXME better Show BuildStatus
                          putStr $ nvr +-+ "(" ++ show status ++ ")"
                        else do
                        -- FIXME hide testing if ga/stable
                        putStr $ nvr +-+ "(" ++ unwords tags ++ ")"
                        unless (isStable tags) $ do
                          updates <- bodhiUpdates
                                     [makeItem "display_user" "0",
                                      makeItem "builds" nvr]
                          case updates of
                            [] -> putStrLn "No update found"
                            [update] -> do
                              -- FIXME could show minus time left using stable_days?
                              let msince = lookupKey "date_testing" update :: Maybe LocalTime
                              case msince of
                                Nothing -> return ()
                                Just date -> do
                                  let since = localTimeToUTC utc date
                                  current <- getCurrentTime
                                  let diff = diffUTCTime current since
                                  putAge diff
                            _ -> putStrLn "More than one update found!"
                      putNewLn
                Just unpushed ->
                  let prefix =
                        let pref =
                              (if length pkgs > 1 then unPackage pkg else "") +-+
                              case breq of
                                Branches brs | length brs <= 1 -> ""
                                _ -> show br
                        in if null pref then "" else pref ++ ":"
                  in putStrLn $ prefix +-+ showCommit unpushed
      where
        isStable :: [String] -> Bool
        isStable = not . all ("-testing" `isSuffixOf`)

        putAge :: NominalDiffTime -> IO ()
        putAge diff = do
          -- FIXME time-1.10 has formatTime of NominalDiffTime
          let (days,nomRest) = diff `divMod'` nominalDay :: (Int,NominalDiffTime)
              nominalHour = 3600 :: NominalDiffTime
              hours = nomRest `div'` nominalHour :: Int
          putStr $ " " ++ plural days "day" +-+ plural hours "hour"

#if !MIN_VERSION_time(1,8,0)
        nominalDay = 3600 * 24 :: NominalDiffTime
#endif


unpushedCmd :: Bool -> (BranchesReq,[String]) -> IO ()
unpushedCmd latest (breq, pkgs) =
  -- FIXME dirty not okay for multiple branches?
  withPackagesByBranches (if latest then HeaderMay else HeaderMust) False dirtyGit AnyNumber unpushedBranch (breq, pkgs)
  where
    -- FIXME note dirty when local changes
    unpushedBranch :: Package -> AnyBranch -> IO ()
    unpushedBranch _ (OtherBranch _) =
      error' "status currently only defined for release branches"
    unpushedBranch pkg rbr@(RelBranch br) = do
      brExists <- checkIfRemoteBranchExists rbr
      if not brExists
        then do
        name <- getDirectoryName
        putStrLn $ name +-+ "has no branch" +-+ show br
        else do
        gitSwitchBranch rbr
        let spec = packageSpec pkg
            prefix =
              let pref =
                    (if length pkgs > 1 then unPackage pkg else "") +-+
                    case breq of
                      Branches brs | length brs <= 1 -> ""
                      _ -> show br
              in if null pref then "" else pref ++ ":"
        ifM (notM (doesFileExist spec))
          (ifM initialPkgRepo
            (putStrLn $ prefix +-+ "initial repo")
            (unlessM (doesFileExist "dead.package") $
             putStrLn $ "missing" +-+ spec)) $
          do
          whenM (isNothing <$> pkgNameVerRel br spec) $ do
            putStrLn "undefined NVR!\n"
            putStr "HEAD "
          unpushed <- gitShortLogN (if latest then Just 1 else Nothing) $
                      Just $ "origin/" ++ show br ++ "..HEAD"
          if latest
            then whenJust (listToMaybe unpushed) $ putCommit prefix
            else mapM_ (putCommit prefix) unpushed

    putCommit prefix = putStrLn . (prefix +-+) . showCommit