@@ -1,19 +1,464 @@
1+{-# LANGUAGE OverloadedStrings #-}
1−module Publish (run) where
2+module Publish
4−import qualified Elm.Project as Project
8+import Control.Exception (bracket_)
9+import Control.Monad (void)
10+import qualified Data.List as List
11+import qualified Data.Utf8 as Utf8
12+import qualified System.Directory as Dir
13+import qualified System.Exit as Exit
14+import qualified System.FilePath as FP
15+import System.FilePath ((</>))
16+import qualified System.Info as Info
17+import qualified System.IO as IO
18+import qualified System.Process as Process
20+import qualified Deps.Bump as Bump
21+import qualified Deps.Diff as Diff
22+import qualified Deps.Registry as Registry
23+import qualified Deps.Website as Website
24+import qualified Elm.Docs as Docs
25+import qualified Elm.Magnitude as M
26+import qualified Elm.Outline as Outline
5−import qualified Elm.Publish as Publish
27+import qualified Elm.Package as Pkg
28+import qualified Elm.Version as V
31+import qualified Json.Decode as D
32+import qualified Json.String as Json
33+import qualified Reporting
34+import Reporting.Doc ((<+>))
35+import qualified Reporting.Doc as D
36+import qualified Reporting.Exit as Exit
37+import qualified Reporting.Exit.Help as Help
6import qualified Reporting.Task as Task
38import qualified Reporting.Task as Task
7−import qualified Reporting.Progress.Terminal as Terminal
39+import qualified Stuff
46+-- TODO mandate no "exposing (..)" in packages to make
47+-- optimization to skip builds in Elm.Details always valid
14run :: () -> () -> IO ()
50run :: () -> () -> IO ()
15run () () =
51run () () =
16− do reporter <- Terminal.create
52+ Reporting.attempt Exit.publishToReport $
17− Task.run reporter $
53+ Task.run $ publish =<< getEnv
18− do summary <- Project.getRoot
54+
19− Publish.publish summary
55+
63+ , _cache :: Stuff.PackageCache
64+ , _manager :: Http.Manager
65+ , _registry :: Registry.Registry
66+ , _outline :: Outline.Outline
70+getEnv :: Task.Task Exit.Publish Env
72+ do maybeRoot <- Task.io $ Stuff.findRoot
75+ Task.throw Exit.PublishNoOutline
78+ do cache <- Task.io $ Stuff.getPackageCache
79+ manager <- Task.io $ Http.getManager
80+ registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache
81+ outlineResult <- Task.io $ Outline.read root
82+ case outlineResult of
84+ return $ Env root cache manager registry outline
87+ Task.throw $ Exit.PublishBadOutline problem
94+publish :: Env -> Task.Task Exit.Publish ()
95+publish env@(Env root cache manager registry outline) =
98+ Task.throw Exit.PublishApplication
100+ Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
101+ do let maybeKnownVersions = Registry.getVersions pkg registry
103+ reportPublishStart pkg vsn maybeKnownVersions
105+ if noExposed exposed then Task.throw Exit.PublishNoExposed else return ()
106+ if badSummary summary then Task.throw Exit.PublishNoSummary else return ()
110+ docs <- error "TODO Project.generateDocs details" details
111+ verifyVersion env pkg vsn docs maybeKnownVersions
112+ commitHash <- verifyTag manager pkg vsn
113+ verifyNoChanges commitHash vsn
114+ zipHash <- verifyZip manager pkg vsn
116+ register manager pkg vsn commitHash zipHash
125+badSummary :: Json.String -> Bool
127+ Json.isEmpty summary || Outline.defaultSummary == summary
130+noExposed :: Outline.Exposed -> Bool
133+ Outline.ExposedList modules ->
136+ Outline.ExposedDict chunks ->
137+ all (null . snd) chunks
144+verifyReadme :: FilePath -> Task.Task Exit.Publish ()
147+ do let readmePath = root </> "README.md"
148+ exists <- File.exists readmePath
151+ return (Left Exit.PublishNoReadme)
154+ do size <- IO.withFile readmePath IO.ReadMode IO.hFileSize
156+ then return (Left Exit.PublishShortReadme)
157+ else return (Right ())
164+verifyLicense :: FilePath -> Task.Task Exit.Publish ()
166+ reportLicensePhase $
167+ do let licensePath = root </> "LICENSE"
168+ exists <- File.exists licensePath
170+ then return (Right ())
171+ else return (Left Exit.PublishNoLicense)
178+verifyTag :: Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String
179+verifyTag manager pkg vsn =
180+ reportTagPhase vsn $
181+ Http.post manager (toTagUrl pkg vsn) [Http.accept "application/json"] Exit.PublishCannotGetTag $ \body ->
182+ case D.fromByteString commitHashDecoder body of
187+ return $ Left (Exit.PublishMissingTag vsn)
190+toTagUrl :: Pkg.Name -> V.Version -> String
192+ "https://api.github.com/repos/" ++ Pkg.toUrl pkg ++ "/git/refs/tags/" ++ V.toChars vsn
195+commitHashDecoder :: D.Decoder e String
198+ D.field "object" (D.field "sha" D.string)
202+-- VERIFY NO LOCAL CHANGES SINCE TAG
205+verifyNoChanges :: String -> V.Version -> Task.Task Exit.Publish ()
206+verifyNoChanges commitHash vsn =
207+ reportChangesPhase $
208+ do maybeGit <- Dir.findExecutable "git"
211+ return $ Left Exit.PublishNoGit
214+ do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
215+ exitCode <- Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
217+ Exit.ExitSuccess -> return $ Right ()
218+ Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn)
222+-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
225+verifyZip :: Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish Http.Sha
226+verifyZip manager pkg vsn =
227+ withTempDir $ \prepublishDir ->
228+ do (sha, archive) <-
229+ reportDownloadPhase $
230+ Http.getArchive manager (toZipUrl pkg vsn)
231+ Exit.PublishCannotGetZip
232+ Exit.PublishCannotDecodeZip
235+ Task.io $ File.writePackage prepublishDir archive
238+ Dir.withCurrentDirectory prepublishDir $
239+ do error "TODO Build.generateDocs"
245+withTempDir :: FilePath -> (FilePath -> IO a) -> IO a
246+withTempDir root callback =
248+ dir = Stuff.prepublishDir root
251+ (Dir.createDirectoryIfMissing True dir)
252+ (Dir.removeDirectoryRecursive dir)
256+toZipUrl :: Pkg.Name -> V.Version -> String
258+ "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/"
267+ | GoodBump V.Version M.Magnitude
270+verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish ()
271+verifyVersion env pkg vsn newDocs publishedVersions =
272+ reportVersionPhase vsn $
273+ case publishedVersions of
276+ then return $ Right GoodStart
277+ else return $ Left $ Exit.PublishNotInitialVersion vsn
279+ Just knownVersions@(Registry.KnownVersions latest previous) ->
280+ if vsn == latest || elem vsn previous
281+ then return $ Left $ Exit.PublishAlreadyPublished vsn
282+ else verifyBump env pkg vsn newDocs knownVersions
285+verifyBump :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Registry.KnownVersions -> IO (Either Exit.Publish GoodVersion)
286+verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.KnownVersions latest _) =
287+ case List.find (\(_ ,new, _) -> vsn == new) (Bump.getPossibilities knownVersions) of
290+ Exit.PublishInvalidBump vsn latest
292+ Just (old, new, magnitude) ->
293+ do result <- Diff.getDocs cache manager pkg old
296+ return $ Left $ Exit.PublishCannotGetDocs dp
300+ changes = Diff.diff oldDocs newDocs
301+ realNew = Diff.bump changes old
304+ then return $ Right $ GoodBump old magnitude
307+ Exit.PublishBadBump old new magnitude realNew (Diff.toMagnitude changes)
314+register :: Http.Manager -> Pkg.Name -> V.Version -> String -> Http.Sha -> Task.Task Exit.Publish ()
315+register manager pkg vsn commitHash sha =
318+ Website.route "/register"
319+ [ ("name", Pkg.toChars pkg)
320+ , ("version", V.toChars vsn)
321+ , ("commit-hash", commitHash)
324+ Task.eio Exit.PublishCannotRegister $
325+ Http.upload manager url
326+ [ Http.filePart "elm.json" "elm.json"
327+ , Http.filePart "docs.json" (error "TODO generate docs, maybe in memory only?")
328+ , Http.filePart "README.md" "README.md"
329+ , Http.stringPart "github-hash" (Http.shaToChars sha)
337+reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> IO ()
338+reportPublishStart pkg vsn maybeKnownVersions =
339+ case maybeKnownVersions of
341+ putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n"
344+ putStrLn $ "Verifying" ++ Pkg.toChars pkg ++ V.toChars vsn ++ "...\n"
351+reportReadmePhase :: IO (Either x a) -> Task.Task x a
354+ "Looking for README.md"
356+ "Problem with your README.md"
359+reportLicensePhase :: IO (Either x a) -> Task.Task x a
362+ "Looking for LICENSE"
364+ "Problem with your LICENSE"
367+reportVersionPhase :: V.Version -> IO (Either x GoodVersion) -> Task.Task x ()
368+reportVersionPhase version work =
370+ vsn = V.toChars version
372+ waiting = "Checking semantic versioning rules. Is " ++ vsn ++ " correct?"
373+ failure = "Version " ++ vsn ++ " is not correct!"
377+ "All packages start at version " ++ V.toChars V.one
379+ GoodBump oldVersion magnitude ->
380+ "Version number " ++ vsn ++ " verified ("
381+ ++ M.toChars magnitude ++ " change, "
382+ ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")"
384+ void $ reportCustomPhase waiting success failure work
387+reportTagPhase :: V.Version -> IO (Either x a) -> Task.Task x a
390+ ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?")
391+ ("Version " ++ V.toChars vsn ++ " is tagged on GitHub")
392+ ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!")
395+reportDownloadPhase :: IO (Either x a) -> Task.Task x a
396+reportDownloadPhase =
398+ "Downloading code from GitHub..."
399+ "Code downloaded successfully from GitHub"
400+ "Could not download code from GitHub!"
403+reportBuildPhase :: IO (Either x a) -> Task.Task x a
406+ "Building downloaded code and generated docs..."
407+ "Downloaded code compiles successfully / docs generated\n"
408+ "Cannot compile downloaded code!"
411+reportChangesPhase :: IO (Either x a) -> Task.Task x a
414+ "Checking for uncommitted changes..."
415+ "No uncommitted changes in local code"
416+ "Your local code is different than the code tagged on GitHub"
419+reportPhase :: String -> String -> String -> IO (Either x a) -> Task.Task x a
420+reportPhase waiting success failure work =
421+ reportCustomPhase waiting (\_ -> success) failure work
424+reportCustomPhase :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a
425+reportCustomPhase waiting success failure work =
428+ Help.toStdout doc >> IO.hFlush IO.stdout
431+ message ++ replicate (length waiting - length message) ' '
434+ do putFlush $ " " <> waitingMark <+> D.fromChars waiting
438+ Right a -> "\r " <> goodMark <+> D.fromChars (padded (success a) ++ "\n")
439+ Left _ -> "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n")
449+ D.green $ if isWindows then "+" else "●"
454+ D.red $ if isWindows then "X" else "✗"
459+ D.dullyellow $ if isWindows then "-" else "→"
464+ Info.os == "mingw32"