content: {-# LANGUAGE OverloadedStrings #-}
  module Publish
    ( run
    )
    where
  
  
  import Control.Exception (bracket_)
  import Control.Monad (void)
  import qualified Data.List as List
  import qualified Data.NonEmptyList as NE
  import qualified Data.Utf8 as Utf8
  import qualified System.Directory as Dir
  import qualified System.Exit as Exit
  import System.FilePath ((</>))
  import qualified System.Info as Info
  import qualified System.IO as IO
  import qualified System.Process as Process
  
  import qualified BackgroundWriter as BW
  import qualified Build
  import qualified Deps.Bump as Bump
  import qualified Deps.Diff as Diff
  import qualified Deps.Registry as Registry
  import qualified Deps.Website as Website
  import qualified Elm.Details as Details
  import qualified Elm.Docs as Docs
  import qualified Elm.Magnitude as M
  import qualified Elm.Outline as Outline
  import qualified Elm.Package as Pkg
  import qualified Elm.Version as V
  import qualified File
  import qualified Http
  import qualified Json.Decode as D
  import qualified Json.String as Json
  import qualified Reporting
  import Reporting.Doc ((<+>))
  import qualified Reporting.Doc as D
  import qualified Reporting.Exit as Exit
  import qualified Reporting.Exit.Help as Help
  import qualified Reporting.Task as Task
  import qualified Stuff
  
  
  
  -- RUN
  
  
  -- TODO mandate no "exposing (..)" in packages to make
  -- optimization to skip builds in Elm.Details always valid
  
  
  run :: () -> () -> IO ()
  run () () =
    Reporting.attempt Exit.publishToReport $
      Task.run $ publish =<< getEnv
  
  
  
  -- ENV
  
  
  data Env =
    Env
      { _root :: FilePath
      , _cache :: Stuff.PackageCache
      , _manager :: Http.Manager
      , _registry :: Registry.Registry
      , _outline :: Outline.Outline
      }
  
  
  getEnv :: Task.Task Exit.Publish Env
  getEnv =
    do  root <- Task.mio Exit.PublishNoOutline $ Stuff.findRoot
        cache <- Task.io $ Stuff.getPackageCache
        manager <- Task.io $ Http.getManager
        registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache
        outline <- Task.eio Exit.PublishBadOutline $ Outline.read root False
        return $ Env root cache manager registry outline
  
  
  
  -- PUBLISH
  
  
  publish ::  Env -> Task.Task Exit.Publish ()
  publish env@(Env root _ manager registry outline) =
    case outline of
      Outline.App _ ->
        Task.throw Exit.PublishApplication
  
      Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
        do  let maybeKnownVersions = Registry.getVersions pkg registry
  
            reportPublishStart pkg vsn maybeKnownVersions
  
            if noExposed  exposed then Task.throw Exit.PublishNoExposed else return ()
            if badSummary summary then Task.throw Exit.PublishNoSummary else return ()
  
            verifyReadme root
            verifyLicense root
            docs <- verifyBuild root
            verifyVersion env pkg vsn docs maybeKnownVersions
            git <- getGit
            commitHash <- verifyTag git manager pkg vsn
            verifyNoChanges git commitHash vsn
            zipHash <- verifyZip env pkg vsn
  
            Task.io $ putStrLn ""
            register manager pkg vsn docs commitHash zipHash
            Task.io $ putStrLn "Success!"
  
  
  
  -- VERIFY SUMMARY
  
  
  badSummary :: Json.String -> Bool
  badSummary summary =
    Json.isEmpty summary || Outline.defaultSummary == summary
  
  
  noExposed :: Outline.Exposed -> Bool
  noExposed exposed =
    case exposed of
      Outline.ExposedList modules ->
        null modules
  
      Outline.ExposedDict chunks ->
        all (null . snd) chunks
  
  
  
  -- VERIFY README
  
  
  verifyReadme :: FilePath -> Task.Task Exit.Publish ()
  verifyReadme root =
    reportReadmeCheck $
    do  let readmePath = root </> "README.md"
        exists <- File.exists readmePath
        case exists of
          False ->
            return (Left Exit.PublishNoReadme)
  
          True ->
            do  size <- IO.withFile readmePath IO.ReadMode IO.hFileSize
                if size < 300
                  then return (Left Exit.PublishShortReadme)
                  else return (Right ())
  
  
  
  -- VERIFY LICENSE
  
  
  verifyLicense :: FilePath -> Task.Task Exit.Publish ()
  verifyLicense root =
    reportLicenseCheck $
    do  let licensePath = root </> "LICENSE"
        exists <- File.exists licensePath
        if exists
          then return (Right ())
          else return (Left Exit.PublishNoLicense)
  
  
  
  -- VERIFY BUILD
  
  
  verifyBuild :: FilePath -> Task.Task Exit.Publish Docs.Documentation
  verifyBuild root =
    reportBuildCheck $ BW.withScope $ \scope ->
      Task.run $
      do  details@(Details.Details _ outline _ _ _ _) <-
            Task.eio Exit.PublishBadDetails $
              Details.load Reporting.silent scope root
  
          exposed <-
            case outline of
              Details.ValidApp _          -> Task.throw Exit.PublishApplication
              Details.ValidPkg _ []     _ -> Task.throw Exit.PublishNoExposed
              Details.ValidPkg _ (e:es) _ -> return (NE.List e es)
  
          Task.eio Exit.PublishBuildProblem $
            Build.fromExposed Reporting.silent root details Build.KeepDocs exposed
  
  
  -- GET GIT
  
  
  newtype Git =
    Git { _run :: [String] -> IO Exit.ExitCode }
  
  
  getGit :: Task.Task Exit.Publish Git
  getGit =
    do  maybeGit <- Task.io $ Dir.findExecutable "git"
        case maybeGit of
          Nothing ->
            Task.throw Exit.PublishNoGit
  
          Just git ->
            return $ Git $ \args ->
              let
                process =
                  (Process.proc git args)
                    { Process.std_in  = Process.CreatePipe
                    , Process.std_out = Process.CreatePipe
                    , Process.std_err = Process.CreatePipe
                    }
              in
              Process.withCreateProcess process $ \_ _ _ handle ->
                Process.waitForProcess handle
  
  
  
  -- VERIFY GITHUB TAG
  
  
  verifyTag :: Git -> Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String
  verifyTag git manager pkg vsn =
    reportTagCheck vsn $
    do  -- https://stackoverflow.com/questions/1064499/how-to-list-all-git-tags
        exitCode <- _run git [ "show", "--name-only", V.toChars vsn, "--" ]
        case exitCode of
          Exit.ExitFailure _ ->
            return $ Left (Exit.PublishMissingTag vsn)
  
          Exit.ExitSuccess ->
            let url = toTagUrl pkg vsn in
            Http.get manager url [Http.accept "application/json"] (Exit.PublishCannotGetTag vsn) $ \body ->
              case D.fromByteString commitHashDecoder body of
                Right hash ->
                  return $ Right hash
  
                Left _ ->
                  return $ Left (Exit.PublishCannotGetTagData vsn url body)
  
  
  toTagUrl :: Pkg.Name -> V.Version -> String
  toTagUrl pkg vsn =
    "https://api.github.com/repos/" ++ Pkg.toUrl pkg ++ "/git/refs/tags/" ++ V.toChars vsn
  
  
  commitHashDecoder :: D.Decoder e String
  commitHashDecoder =
    Utf8.toChars <$>
      D.field "object" (D.field "sha" D.string)
  
  
  
  -- VERIFY NO LOCAL CHANGES SINCE TAG
  
  
  verifyNoChanges :: Git -> String -> V.Version -> Task.Task Exit.Publish ()
  verifyNoChanges git commitHash vsn =
    reportLocalChangesCheck $
    do  -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
        exitCode <- _run git [ "diff-index", "--quiet", commitHash, "--" ]
        case exitCode of
          Exit.ExitSuccess   -> return $ Right ()
          Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn)
  
  
  
  -- VERIFY THAT ZIP BUILDS / COMPUTE HASH
  
  
  verifyZip :: Env -> Pkg.Name -> V.Version -> Task.Task Exit.Publish Http.Sha
  verifyZip (Env root _ manager _ _) pkg vsn =
    withPrepublishDir root $ \prepublishDir ->
      do  let url = toZipUrl pkg vsn
  
          (sha, archive) <-
            reportDownloadCheck $
              Http.getArchive manager url
                Exit.PublishCannotGetZip
                (Exit.PublishCannotDecodeZip url)
                (return . Right)
  
          Task.io $ File.writePackage prepublishDir archive
  
          reportZipBuildCheck $
            Dir.withCurrentDirectory prepublishDir $
              verifyZipBuild prepublishDir
  
          return sha
  
  
  toZipUrl :: Pkg.Name -> V.Version -> String
  toZipUrl pkg vsn =
    "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/"
  
  
  withPrepublishDir :: FilePath -> (FilePath -> Task.Task x a) -> Task.Task x a
  withPrepublishDir root callback =
    let
      dir = Stuff.prepublishDir root
    in
    Task.eio id $
      bracket_
        (Dir.createDirectoryIfMissing True dir)
        (Dir.removeDirectoryRecursive dir)
        (Task.run (callback dir))
  
  
  verifyZipBuild :: FilePath -> IO (Either Exit.Publish ())
  verifyZipBuild root =
    BW.withScope $ \scope -> Task.run $
    do  details@(Details.Details _ outline _ _ _ _) <-
          Task.eio Exit.PublishZipBadDetails $
            Details.load Reporting.silent scope root
  
        exposed <-
          case outline of
            Details.ValidApp _          -> Task.throw Exit.PublishZipApplication
            Details.ValidPkg _ []     _ -> Task.throw Exit.PublishZipNoExposed
            Details.ValidPkg _ (e:es) _ -> return (NE.List e es)
  
        _ <- Task.eio Exit.PublishZipBuildProblem $
          Build.fromExposed Reporting.silent root details Build.KeepDocs exposed
  
        return ()
  
  
  
  -- VERIFY VERSION
  
  
  data GoodVersion
    = GoodStart
    | GoodBump V.Version M.Magnitude
  
  
  verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish ()
  verifyVersion env pkg vsn newDocs publishedVersions =
    reportSemverCheck vsn $
      case publishedVersions of
        Nothing ->
          if vsn == V.one
          then return $ Right GoodStart
          else return $ Left $ Exit.PublishNotInitialVersion vsn
  
        Just knownVersions@(Registry.KnownVersions latest previous) ->
          if vsn == latest || elem vsn previous
          then return $ Left $ Exit.PublishAlreadyPublished vsn
          else verifyBump env pkg vsn newDocs knownVersions
  
  
  verifyBump :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Registry.KnownVersions -> IO (Either Exit.Publish GoodVersion)
  verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.KnownVersions latest _) =
    case List.find (\(_ ,new, _) -> vsn == new) (Bump.getPossibilities knownVersions) of
      Nothing ->
        return $ Left $
          Exit.PublishInvalidBump vsn latest
  
      Just (old, new, magnitude) ->
        do  result <- Diff.getDocs cache manager pkg old
            case result of
              Left dp ->
                return $ Left $ Exit.PublishCannotGetDocs old new dp
  
              Right oldDocs ->
                let
                  changes = Diff.diff oldDocs newDocs
                  realNew = Diff.bump changes old
                in
                if new == realNew
                then return $ Right $ GoodBump old magnitude
                else
                  return $ Left $
                    Exit.PublishBadBump old new magnitude realNew (Diff.toMagnitude changes)
  
  
  
  -- REGISTER PACKAGES
  
  
  register :: Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task.Task Exit.Publish ()
  register manager pkg vsn docs commitHash sha =
    let
      url =
        Website.route "/register"
          [ ("name", Pkg.toChars pkg)
          , ("version", V.toChars vsn)
          , ("commit-hash", commitHash)
          ]
    in
    Task.eio Exit.PublishCannotRegister $
      Http.upload manager url
        [ Http.filePart "elm.json" "elm.json"
        , Http.jsonPart "docs.json" "docs.json" (Docs.encode docs)
        , Http.filePart "README.md" "README.md"
        , Http.stringPart "github-hash" (Http.shaToChars sha)
        ]
  
  
  
  -- REPORTING
  
  
  reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> Task.Task x ()
  reportPublishStart pkg vsn maybeKnownVersions =
    Task.io $
    case maybeKnownVersions of
      Nothing ->
        putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n"
  
      Just _ ->
        putStrLn $ "Verifying " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " ...\n"
  
  
  
  -- REPORTING PHASES
  
  
  reportReadmeCheck :: IO (Either x a) -> Task.Task x a
  reportReadmeCheck =
    reportCheck
      "Looking for README.md"
      "Found README.md"
      "Problem with your README.md"
  
  
  reportLicenseCheck :: IO (Either x a) -> Task.Task x a
  reportLicenseCheck =
    reportCheck
      "Looking for LICENSE"
      "Found LICENSE"
      "Problem with your LICENSE"
  
  
  reportBuildCheck :: IO (Either x a) -> Task.Task x a
  reportBuildCheck =
    reportCheck
      "Verifying documentation..."
      "Verified documentation"
      "Problem with documentation"
  
  
  reportSemverCheck :: V.Version -> IO (Either x GoodVersion) -> Task.Task x ()
  reportSemverCheck version work =
    let
      vsn = V.toChars version
  
      waiting = "Checking semantic versioning rules. Is " ++ vsn ++ " correct?"
      failure = "Version " ++ vsn ++ " is not correct!"
      success result =
        case result of
          GoodStart ->
            "All packages start at version " ++ V.toChars V.one
  
          GoodBump oldVersion magnitude ->
            "Version number " ++ vsn ++ " verified ("
            ++ M.toChars magnitude ++ " change, "
            ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")"
    in
    void $ reportCustomCheck waiting success failure work
  
  
  reportTagCheck :: V.Version -> IO (Either x a) -> Task.Task x a
  reportTagCheck vsn =
    reportCheck
      ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?")
      ("Version " ++ V.toChars vsn ++ " is tagged on GitHub")
      ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!")
  
  
  reportDownloadCheck :: IO (Either x a) -> Task.Task x a
  reportDownloadCheck =
    reportCheck
      "Downloading code from GitHub..."
      "Code downloaded successfully from GitHub"
      "Could not download code from GitHub!"
  
  
  reportLocalChangesCheck :: IO (Either x a) -> Task.Task x a
  reportLocalChangesCheck =
    reportCheck
      "Checking for uncommitted changes..."
      "No uncommitted changes in local code"
      "Your local code is different than the code tagged on GitHub"
  
  
  reportZipBuildCheck :: IO (Either x a) -> Task.Task x a
  reportZipBuildCheck =
    reportCheck
      "Verifying downloaded code..."
      "Downloaded code compiles successfully"
      "Cannot compile downloaded code!"
  
  
  reportCheck :: String -> String -> String -> IO (Either x a) -> Task.Task x a
  reportCheck waiting success failure work =
    reportCustomCheck waiting (\_ -> success) failure work
  
  
  reportCustomCheck :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a
  reportCustomCheck waiting success failure work =
    let
      putFlush doc =
        Help.toStdout doc >> IO.hFlush IO.stdout
  
      padded message =
        message ++ replicate (length waiting - length message) ' '
    in
    Task.eio id $
    do  putFlush $ "  " <> waitingMark <+> D.fromChars waiting
        result <- work
        putFlush $
          case result of
            Right a -> "\r  " <> goodMark <+> D.fromChars (padded (success a) ++ "\n")
            Left _  -> "\r  " <> badMark  <+> D.fromChars (padded failure ++ "\n\n")
  
        return result
  
  
  -- MARKS
  
  
  goodMark :: D.Doc
  goodMark =
    D.green $ if isWindows then "+" else "●"
  
  
  badMark :: D.Doc
  badMark =
    D.red $ if isWindows then "X" else "✗"
  
  
  waitingMark :: D.Doc
  waitingMark =
    D.dullyellow $ if isWindows then "-" else "→"
  
  
  isWindows :: Bool
  isWindows =
    Info.os == "mingw32"
  