{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE ViewPatterns       #-}
module Stackage.CompleteBuild
    ( BuildType (..)
    , BumpType (..)
    , BuildFlags (..)
    , checkPlan
    , getStackageAuthToken
    , createPlan
    , fetch
    , makeBundle
    , upload
    , hackageDistro
    , uploadGithub
    ) where

import System.Directory (getAppUserDataDirectory)
import Filesystem (isDirectory, createTree, isFile, rename)
import Filesystem.Path (parent)
import Control.Concurrent        (threadDelay, getNumCapabilities)
import Control.Concurrent.Async  (withAsync)
import Data.Default.Class        (def)
import Data.Semigroup            (Max (..), Option (..))
import Data.Text.Read            (decimal)
import Data.Time
import Data.Yaml                 (decodeFileEither, encodeFile, decodeEither')
import Network.HTTP.Client
import Network.HTTP.Client.Conduit (bodyReaderSource)
import Network.HTTP.Client.TLS   (tlsManagerSettings)
import Stackage.BuildConstraints
import Stackage.BuildPlan
import Stackage.CheckBuildPlan
import Stackage.PerformBuild
import Stackage.Prelude
import Stackage.ServerBundle
import Stackage.UpdateBuildPlan
import Stackage.Upload
import System.Environment        (lookupEnv)
import System.IO                 (BufferMode (LineBuffering), hSetBuffering)
import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift)
import Data.Function (fix)
import Control.Concurrent.Async (Concurrently (..))

-- | Flags passed in from the command line.
data BuildFlags = BuildFlags
    { bfEnableTests      :: !Bool
    , bfEnableHaddock    :: !Bool
    , bfDoUpload         :: !Bool
    , bfEnableLibProfile :: !Bool
    , bfEnableExecDyn    :: !Bool
    , bfVerbose          :: !Bool
    , bfSkipCheck        :: !Bool
    , bfServer           :: !StackageServer
    , bfBuildHoogle      :: !Bool
    , bfBundleDest       :: !(Maybe FilePath)
    , bfGitPush          :: !Bool
    -- ^ push to Git (when doing an LTS build)
    , bfJobs             :: !(Maybe Int)
    , bfPlanFile         :: !(Maybe FilePath)
    , bfPreBuild         :: !Bool
    , bfLoadPlan         :: !Bool
    } deriving (Show)

data BuildType = Nightly | LTS BumpType Text
    deriving (Show, Read, Eq, Ord)

data BumpType = Major | Minor
    deriving (Show, Read, Eq, Ord)

data Settings = Settings
    { plan      :: BuildPlan
    , planFile  :: FilePath
    , buildDir  :: FilePath
    , logDir    :: FilePath
    , title     :: Text -> Text -- ^ GHC version -> title
    , slug      :: Text
    , postBuild :: IO ()
    , distroName :: Text -- ^ distro name on Hackage
    , snapshotType :: SnapshotType
    , bundleDest :: FilePath
    }

nightlyPlanFile :: Text -- ^ day
                -> FilePath
nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"

nightlySettings :: Text -- ^ day
                -> BuildFlags
                -> BuildPlan
                -> Settings
nightlySettings day bf plan' = Settings
    { planFile = fromMaybe (nightlyPlanFile day) (bfPlanFile bf)
    , buildDir = fpFromText $ "builds/nightly"
    , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
    , title = \ghcVer -> concat
        [ "Stackage Nightly "
        , day
        , ", GHC "
        , ghcVer
        ]
    , slug = slug'
    , plan = plan'
    , postBuild = return ()
    , distroName = "Stackage"
    , snapshotType = STNightly
    , bundleDest = fromMaybe
        (fpFromText $ "stackage-nightly-" ++ day ++ ".bundle")
        (bfBundleDest bf)
    }
  where
    slug' = "nightly-" ++ day

parseGoal :: MonadThrow m
          => BumpType
          -> Text
          -> m (LTSVer -> Bool)
parseGoal _ "" = return $ const True
parseGoal bumpType t =
    case decimal t of
        Right (major, "") -> return $ \(LTSVer major' _) ->
            case bumpType of
                -- For major bumps: specifying 2 means we want to ignore
                -- anything in the 2.* range
                Major -> major' < major

                -- But for minor bumps, specifying 2 means we want to include
                -- everything in 2.*, and start ignore 3.*
                Minor -> major' <= major
        _ ->
            case parseLTSRaw t of
                Nothing -> throwM $ ParseGoalFailure t
                Just x -> return (< x)

data ParseGoalFailure = ParseGoalFailure Text
    deriving (Show, Typeable)
instance Exception ParseGoalFailure

getSettings :: Manager -> BuildFlags -> BuildType -> Maybe FilePath -> IO Settings
getSettings man bf Nightly mplanFile = do
    day <- tshow . utctDay <$> getCurrentTime
    plan' <- case mplanFile of
        Nothing -> do
            bc <- defaultBuildConstraints man
            pkgs <- getLatestAllowedPlans bc
            newBuildPlan pkgs bc
        Just file -> decodeFileEither (fpToString file) >>= either throwIO return
    return $ nightlySettings day bf plan'
getSettings man bf (LTS bumpType goal) Nothing = do
    matchesGoal <- parseGoal bumpType goal
    Option mlts <- fmap (fmap getMax) $ runResourceT
        $ sourceDirectory "."
       $= concatMapC (parseLTSVer . filename)
       $= filterC matchesGoal
       $$ foldMapC (Option . Just . Max)

    (new, plan') <- case bumpType of
        Major -> do
            let new =
                    case mlts of
                        Nothing -> LTSVer 0 0
                        Just (LTSVer x _) -> LTSVer (x + 1) 0
            bc <- defaultBuildConstraints man
            pkgs <- getLatestAllowedPlans bc
            plan' <- newBuildPlan pkgs bc
            return (new, plan')
        Minor -> do
            old <- maybe (error "No LTS plans found in current directory") return mlts
            oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
                   >>= either throwM return
            let new = incrLTSVer old
            let bc = updateBuildConstraints oldplan
            pkgs <- getLatestAllowedPlans bc
            plan' <- newBuildPlan pkgs bc
            return (new, plan')

    let newfile = renderLTSVer new

    return Settings
        { planFile = fromMaybe newfile (bfPlanFile bf)
        , buildDir = fpFromText $ "builds/lts"
        , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
        , title = \ghcVer -> concat
            [ "LTS Haskell "
            , tshow new
            , ", GHC "
            , ghcVer
            ]
        , slug = "lts-" ++ tshow new
        , plan = plan'
        , postBuild = do
            let git args = withCheckedProcess
                    (proc "git" args) $ \ClosedStream Inherited Inherited ->
                        return ()
            putStrLn "Committing new LTS file to Git"
            git ["add", fpToString newfile]
            git ["commit", "-m", "Added new LTS release: " ++ show new]
            when (bfGitPush bf) $ do
                putStrLn "Pushing to Git repository"
                git ["push"]
        , distroName = "LTSHaskell"
        , snapshotType =
            case new of
                LTSVer x y -> STLTS x y
        , bundleDest = fromMaybe
            (fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle")
            (bfBundleDest bf)
        }

data LTSVer = LTSVer !Int !Int
    deriving (Eq, Ord)
instance Show LTSVer where
    show (LTSVer x y) = concat [show x, ".", show y]
incrLTSVer :: LTSVer -> LTSVer
incrLTSVer (LTSVer x y) = LTSVer x (y + 1)

parseLTSVer :: FilePath -> Maybe LTSVer
parseLTSVer fp = do
    w <- stripPrefix "lts-" $ fpToText fp
    x <- stripSuffix ".yaml" w
    parseLTSRaw x

parseLTSRaw :: Text -> Maybe LTSVer
parseLTSRaw x = do
    Right (major, y) <- Just $ decimal x
    z <- stripPrefix "." y
    Right (minor, "") <- Just $ decimal z
    return $ LTSVer major minor

createPlan :: Target
           -> FilePath
           -> IO ()
createPlan target dest = withManager tlsManagerSettings $ \man -> do
    putStrLn $ "Creating plan for: " ++ tshow target
    bc <-
        case target of
            TargetMinor x y -> do
                let url = concat
                        [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-"
                        , show x
                        , "."
                        , show (y - 1)
                        , ".yaml"
                        ]
                putStrLn $ "Downloading old plan from " ++ pack url
                req <- parseUrl url
                res <- httpLbs req man
                oldplan <- either throwM return
                         $ decodeEither' (toStrict $ responseBody res)
                return $ updateBuildConstraints oldplan
            _ -> defaultBuildConstraints man

    plan <- planFromConstraints bc

    putStrLn $ "Writing build plan to " ++ fpToText dest
    encodeFile (fpToString dest) plan

planFromConstraints bc = do
    putStrLn "Creating build plan"
    plans <- getLatestAllowedPlans bc
    newBuildPlan plans bc

renderLTSVer :: LTSVer -> FilePath
renderLTSVer lts = fpFromText $ concat
    [ "lts-"
    , tshow lts
    , ".yaml"
    ]

-- | Just print a message saying "still alive" every minute, to appease Travis.
stillAlive :: IO () -> IO ()
stillAlive inner =
    withAsync (printer 1) $ const inner
  where
    printer i = forever $ do
        threadDelay 60000000
        putStrLn $ "Still alive: " ++ tshow i
        printer $! i + 1

-- | Generate and check a new build plan, but do not execute it.
--
-- Since 0.3.1
checkPlan :: Maybe FilePath -> IO ()
checkPlan mfp = stillAlive $ withManager tlsManagerSettings $ \man -> do
    plan <-
        case mfp of
            Nothing -> do
                putStrLn "Loading default build constraints"
                bc <- defaultBuildConstraints man

                plan <- planFromConstraints bc

                putStrLn $ "Writing build plan to check-plan.yaml"
                encodeFile "check-plan.yaml" plan

                return plan
            Just fp -> do
                putStrLn $ "Loading plan from " ++ fpToText fp
                decodeFileEither (fpToString fp) >>= either throwM return

    putStrLn "Checking plan"
    checkBuildPlan plan

    putStrLn "Plan seems valid!"

getPerformBuild :: BuildFlags -> Settings -> IO PerformBuild
getPerformBuild buildFlags Settings {..} = do
    jobs <- maybe getNumCapabilities return $ bfJobs buildFlags
    return PerformBuild
        { pbPlan = plan
        , pbInstallDest = buildDir
        , pbLogDir = logDir
        , pbLog = hPut stdout
        , pbJobs = jobs
        , pbGlobalInstall = False
        , pbEnableTests = bfEnableTests buildFlags
        , pbEnableHaddock = bfEnableHaddock buildFlags
        , pbEnableLibProfiling = bfEnableLibProfile buildFlags
        , pbEnableExecDyn = bfEnableExecDyn buildFlags
        , pbVerbose = bfVerbose buildFlags
        , pbAllowNewer = bfSkipCheck buildFlags
        , pbBuildHoogle = bfBuildHoogle buildFlags
        }

{- FIXME remove
-- | Make a complete plan, build, test and upload bundle, docs and
-- distro.
completeBuild :: BuildType -> BuildFlags -> IO ()
completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
    hSetBuffering stdout LineBuffering

    settings@Settings {..} <- if bfLoadPlan buildFlags
        then
            case bfPlanFile buildFlags of
                Nothing -> error "When loading plan, plan file must be specified"
                Just file -> do
                    putStrLn $ "Loading build plan from: " ++ fpToText file
                    getSettings man buildFlags buildType $ Just file
        else do
            putStrLn $ "Loading settings for: " ++ tshow buildType
            settings@Settings {..} <- getSettings man buildFlags buildType Nothing

            putStrLn $ "Writing build plan to: " ++ fpToText planFile
            encodeFile (fpToString planFile) plan

            if bfSkipCheck buildFlags
                then putStrLn "Skipping build plan check"
                else do
                    putStrLn "Checking build plan"
                    checkBuildPlan plan

            return settings

    pb <- getPerformBuild buildFlags settings

    if bfPreBuild buildFlags
        then prefetchPackages pb
        else do
            putStrLn "Performing build"
            performBuild pb >>= mapM_ putStrLn

            putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest
            createBundleV2 CreateBundleV2
                { cb2Plan = plan
                , cb2Type = snapshotType
                , cb2DocsDir = pbDocDir pb
                , cb2Dest = bundleDest
                }

            postBuild `catchAny` print

            when (bfDoUpload buildFlags) $
                finallyUpload
                    buildFlags
                    settings
                    man
-}

getStackageAuthToken :: IO Text
getStackageAuthToken = do
    mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
    case mtoken of
        Nothing -> decodeUtf8 <$> readFile "/auth-token"
        Just token -> return $ pack token

{- FIXME remove
-- | The final part of the complete build process: uploading a bundle,
-- docs and a distro to hackage.
finallyUpload :: BuildFlags
              -> Settings -> Manager -> IO ()
finallyUpload buildFlags settings@Settings{..} man = do
    let server = bfServer buildFlags
    pb <- getPerformBuild buildFlags settings

    putStrLn "Uploading bundle to Stackage Server"

    token <- getStackageAuthToken

    res <- flip uploadBundleV2 man UploadBundleV2
        { ub2Server = server
        , ub2AuthToken = token
        , ub2Bundle = bundleDest
        }
    putStrLn $ "New snapshot available at: " ++ res

-}

hackageDistro
    :: FilePath -- ^ plan file
    -> Target
    -> IO ()
hackageDistro planFile target = withManager tlsManagerSettings $ \man -> do
    plan <- decodeFileEither (fpToString planFile) >>= either throwM return
    ecreds <- tryIO $ readFile "/hackage-creds"
    case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
        [username, password] -> do
            putStrLn $ "Uploading as Hackage distro: " ++ distroName
            res2 <- uploadHackageDistro distroName plan username password man
            putStrLn $ "Distro upload response: " ++ tshow res2
        _ -> error "No Hackage creds found at /hackage-creds"
  where
    distroName =
        case target of
            TargetNightly -> "Stackage"
            TargetMajor _ -> "LTSHaskell"
            TargetMinor _ _ -> "LTSHaskell"

uploadGithub
    :: FilePath -- ^ plan file
    -> Target
    -> IO ()
uploadGithub planFile target = do
    let repoUrl =
            case target of
                TargetNightly -> "git@github.com:fpco/stackage-nightly"
                _ -> "git@github.com:fpco/lts-haskell"

    root <- fpFromString <$> getAppUserDataDirectory "stackage-curator"

    now <- getCurrentTime

    let repoDir =
            case target of
                TargetNightly -> root </> "stackage-nightly"
                _ -> root </> "lts-haskell"

        destFP =
            case target of
                TargetNightly -> repoDir </> (fpFromString $ concat
                    [ "nightly-"
                    , show $ utctDay now
                    , ".yaml"
                    ])
                TargetMajor x -> repoDir </> (fpFromString $ concat
                    [ "lts-"
                    , show x
                    , ".0.yaml"
                    ])
                TargetMinor x y -> repoDir </> (fpFromString $ concat
                    [ "lts-"
                    , show x
                    , "."
                    , show y
                    , ".yaml"
                    ])

        runIn wdir cmd args = do
            putStrLn $ concat
                [ fpToText wdir
                , ": "
                , tshow (cmd:args)
                ]
            withCheckedProcess
                (proc cmd args)
                    { cwd = Just $ fpToString wdir
                    } $ \ClosedStream Inherited Inherited -> return ()

        git = runIn repoDir "git"

    exists <- isDirectory repoDir
    if exists
        then do
            git ["fetch"]
            git ["checkout", "origin/master"]
        else do
            createTree $ parent repoDir
            runIn "." "git" ["clone", repoUrl, fpToString repoDir]

    runResourceT $ sourceFile planFile $$ (sinkFile destFP :: Sink ByteString (ResourceT IO) ())
    git ["add", fpToString destFP]
    git ["commit", "-m", "Checking in " ++ fpToString (filename destFP)]
    git ["push", "origin", "HEAD:master"]

upload
    :: FilePath -- ^ bundle file
    -> StackageServer -- ^ server URL
    -> IO ()
upload bundleFile server = withManager tlsManagerSettings $ \man -> do
    putStrLn "Uploading bundle to Stackage Server"

    token <- getStackageAuthToken

    res <- flip uploadBundleV2 man UploadBundleV2
        { ub2Server = server
        , ub2AuthToken = token
        , ub2Bundle = bundleFile
        }
    putStrLn $ "New snapshot available at: " ++ res

makeBundle
    :: FilePath -- ^ plan file
    -> FilePath -- ^ bundle file
    -> Target
    -> Maybe Int -- ^ jobs
    -> Bool -- ^ skip tests?
    -> Bool -- ^ skip haddock?
    -> Bool -- ^ skip hoogle?
    -> Bool -- ^ enable library profiling?
    -> Bool -- ^ enable executable dynamic?
    -> Bool -- ^ verbose?
    -> Bool -- ^ allow-newer?
    -> IO ()
makeBundle
  planFile bundleFile target mjobs skipTests skipHaddocks skipHoogle
  enableLibraryProfiling enableExecutableDynamic verbose allowNewer
        = do
    plan <- decodeFileEither (fpToString planFile) >>= either throwM return
    jobs <- maybe getNumCapabilities return mjobs
    let pb = PerformBuild
            { pbPlan = plan
            , pbInstallDest =
                case target of
                    TargetNightly -> "builds/nightly"
                    TargetMajor x -> fpFromText $ "builds/lts-" ++ tshow x
                    TargetMinor x _ -> fpFromText $ "builds/lts-" ++ tshow x
            , pbLog = hPut stdout
            , pbLogDir =
                case target of
                    TargetNightly -> "logs/nightly"
                    TargetMajor x -> fpFromText $ "logs/lts-" ++ tshow x
                    TargetMinor x _ -> fpFromText $ "logs/lts-" ++ tshow x
            , pbJobs = jobs
            , pbGlobalInstall = False
            , pbEnableTests = not skipTests
            , pbEnableHaddock = not skipHaddocks
            , pbEnableLibProfiling = enableLibraryProfiling
            , pbEnableExecDyn = enableExecutableDynamic
            , pbVerbose = verbose
            , pbAllowNewer = allowNewer
            , pbBuildHoogle = not skipHoogle
            }

    putStrLn "Performing build"
    performBuild pb >>= mapM_ putStrLn

    putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleFile
    createBundleV2 CreateBundleV2
        { cb2Plan = plan
        , cb2Type =
            case target of
                TargetNightly -> STNightly
                TargetMajor x -> STLTS x 0
                TargetMinor x y -> STLTS x y
        , cb2DocsDir = pbDocDir pb
        , cb2Dest = bundleFile
        }

fetch :: FilePath -> IO ()
fetch planFile = withManager tlsManagerSettings $ \man -> do
    -- First make sure to fetch all of the dependencies... just in case Hackage
    -- has an outage. Don't feel like wasting hours of CPU time.
    putStrLn "Pre-fetching all packages"

    plan <- decodeFileEither (fpToString planFile) >>= either throwM return

    cabalDir <- fpFromString <$> getAppUserDataDirectory "cabal"
    parMapM_ 8 (download man cabalDir) $ mapToList $ bpPackages plan
  where
    download man cabalDir (display -> name, display . ppVersion -> version) = do
        unlessM (isFile fp) $ do
            hPut stdout $ encodeUtf8 $ concat
                [ "Downloading "
                , name
                , "-"
                , version
                , "\n"
                ]
            createTree $ parent fp
            req <- parseUrl url
            withResponse req man $ \res -> do
                let tmp = fp <.> "tmp"
                runResourceT $ bodyReaderSource (responseBody res) $$ sinkFile tmp
                rename tmp fp
      where
        url = unpack $ concat
            [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
            , name
            , "-"
            , version
            , ".tar.gz"
            ]
        fp = cabalDir </>
             "packages" </>
             "hackage.haskell.org" </>
             fpFromText name </>
             fpFromText version </>
             fpFromText (concat [name, "-", version, ".tar.gz"])

parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono)
         => Int
         -> (Element mono -> m ())
         -> mono
         -> m ()
parMapM_ (max 1 -> 1) f xs = mapM_ f xs
parMapM_ cnt f xs0 = do
    var <- liftBase $ newTVarIO $ toList xs0
    run <- askRunBase
    let worker :: IO ()
        worker = run $ fix $ \loop -> join $ atomically $ do
            xs <- readTVar var
            case xs of
                [] -> return $ return ()
                x:xs' -> do
                    writeTVar var xs'
                    return $ do
                        f x
                        loop
        workers 1 = Concurrently worker
        workers i = Concurrently worker *> workers (i - 1)
    liftBase $ runConcurrently $ workers cnt