diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,23 @@
# Changelog for Hup
+Major changes to the library API and executable behaviour will be
+documented here.
+
+## 0.3.0.3
+
+- Library API: no changes.
+- Executable behaviour: the environment variable used to pass in a password
+ has changed from PASSWORD to HUP_HACKAGE_PASSWORD.
+ (Fixes [#14](https://github.com/phlummox/hup/issues/14))
+- Repository changes:
+ - Renamed source code directories
+ - Did some (API-unchanging) tidying of source code files
+ - Got basic builds and tests working on Windows and MacOS again
+ (fixes [#7](https://github.com/phlummox/hup/issues/7))
+ - Added a "smoke test" (test of basic app functionality)
+ against an instance of hackage-server running in a Docker
+ container.
+
## 0.3.0.2
- Library API: no changes.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,223 @@
+# hup [](https://hackage.haskell.org/package/hup)
+
+[](https://github.com/phlummox/hup/actions/workflows/ci.yml)
+[](https://ci.appveyor.com/project/phlummox/hup/branch/master)
+
+Small program for building and uploading packages and documentation
+built with the [`stack`][stack] build tool to a hackage server.
+
+[stack]: https://www.haskellstack.org/
+
+For instance, to build and upload package documentation to
+ for a package candidate:
+
+```
+$ hup docboth --candidate --user myHackageUserID --password myHackagePassword
+```
+
+Instead of providing a password on the command line, you can set the
+`HUP_HACKAGE_PASSWORD` environment variable and `hup` will use that as the
+password.
+
+In addition to `stack`, `hup` requires the `cabal` executable,
+but will install an appropriate `cabal` if it doesn't find one in the
+binaries for the package snapshot your project is using.
+
+## Installation
+
+The recommended install method is to run:
+
+```
+$ stack --resolver=lts-11 build --copy-bins hup
+```
+
+On Linux, this will install `hup` to your `~/.local/bin` directory --
+ensure that it's on your PATH, and you're good to go.
+
+## Quick usage
+
+Try:
+
+```
+$ cd /path/to/my/project
+$ stack build
+$ hup packboth -u myHackageUserID -p myHackagePassword
+$ hup docboth -u myHackageUserID -p myHackagePassword
+```
+
+## Usage
+
+
+* `hup [COMMAND] ... [OPTIONS]`
+
+ Build and/or upload packages or documentation to a hackage server. A server
+ url should be of the format PROTOCOL://SERVER[:PORT]/, and defaults to
+ https://hackage.haskell.org/ if not specified.
+
+ A password can also be given in the HUP_HACKAGE_PASSWORD environment variable
+ instead of on the command line.
+
+ 'hup --help=all' will give help for all commands.
+
+* Commands:
+
+ packbuild Build source distribution .tgz for a package.
+ packup Upload FILE as a package (or candidate package).
+ packboth Build source distribution .tgz and upload as package (or
+ candidate package).
+ docbuild Build documentation for a package.
+ docup Upload FILE as documentation.
+ docboth Build and upload documentation for a package.
+
+* Common flags:
+
+ -v --verbose be verbose
+ -h --help Display help message
+ -V --version Print version information
+ --numeric-version Print just the version number
+
+
+ '--help=bash' will output code for bash command-line completion.
+
+### Subcommand details
+
+
+
+* `hup packbuild [OPTIONS]`
+
+ Build source distribution .tgz for a package.
+
+* `hup packup [OPTIONS] FILE`
+
+ Upload FILE as a package (or candidate package).
+
+ Flags:
+
+ -s --server=URL
+ -c --candidate
+ -u --user=USER
+ -p --password=PASSWORD
+* `hup packboth [OPTIONS]`
+
+ Build source distribution .tgz and upload as package (or candidate package).
+
+ Flags:
+
+ -s --server=URL
+ -c --candidate
+ -u --user=USER
+ -p --password=PASSWORD
+* `hup docbuild [OPTIONS]`
+
+ Build documentation for a package.
+
+ Flags:
+
+ -e --executables Run haddock for Executables targets
+ -t --tests Run haddock for Test Suite targets
+ -i --internal Run haddock for internal modules and include
+ all symbols
+ --haddock-arguments=ARGS extra args to pass to haddock
+ -q --quick quick build - don't build docco for
+ dependencies (links may be broken)
+* `hup docup [OPTIONS] FILE`
+
+ Upload FILE as documentation.
+
+ Flags:
+
+ -s --server=URL
+ -c --candidate
+ -u --user=USER
+ -p --password=PASSWORD
+* `hup docboth [OPTIONS]`
+
+ Build and upload documentation for a package.
+
+ Flags:
+
+ -e --executables Run haddock for Executables targets
+ -t --tests Run haddock for Test Suite targets
+ -i --internal Run haddock for internal modules and include
+ all symbols
+ --haddock-arguments=ARGS extra args to pass to haddock
+ -q --quick quick build - don't build docco for
+ dependencies (links may be broken)
+ -s --server=URL
+ -c --candidate
+ -u --user=USER
+ -p --password=PASSWORD
+
+
+## Library API
+
+For documentation of the library, see the [Hackage documentation][hackage-hup].
+
+[hackage-hup]: https://hackage.haskell.org/package/hup
+
+## Troubleshooting
+
+### I get an error during upload that says "...: does not exist (no such protocol name: tcp)"
+
+This is not actually a bug in `hup`, but is found in e.g. Docker containers
+that don't have all the packages needed for networking - see e.g.
+[here](https://stackoverflow.com/questions/46322773/yesod-app-in-docker-container-cant-make-network-requests) on StackOverflow.
+
+You will need to install networking packages appropriate for your distro - on Ubuntu, something like ca-certificates, libgnutls28 (or another version of the GNU TLS library), and netbase.
+
+### I get some sort of error when building documents that says "...haddock: internal error: ... hGetContents: invalid argument (invalid byte sequence)"
+
+Again, this isn't actually a bug in `hup`, but happens (e.g. in Docker
+containers) when the system locale is not properly set up (see a bug report
+[here](https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=871839) arising from a
+similar issue). Annoyingly, `haddock` depends on the locale being properly set,
+though it doesn't really seem necessary.
+
+Try running `locale-gen "en_US.UTF-8"` to generate an appropriate UTF-8
+locale, and `export LC_ALL="en_US.UTF-8"` so that the locale can be found
+from environment variables.
+
+## Bash command-line completion
+
+To enable bash command-completion:
+
+Run
+
+```
+$ hup --help=bash > hup.complete
+```
+
+then either "`source hup.complete`" or "`. hup.complete`".
+
+## Defaults
+
+Uses "`https://hackage.haskell.org/`" as the default server location,
+but see the `DefaultServerUrl` module if you want to patch this to
+something else before installing.
+
+## Bugs and limitations
+
+- Some very basic tests of library and app functionality are run on MS Windows
+ and MacOS virtual machines using GitHub and Appveyor's CI/CD capabilities, but
+ no extensive testing on those platforms is performed.
+
+## Feature requests
+
+So that actual bugs and defects aren't cluttered by other issues,
+proposed features and feature requests are maintained as *closed* issues on
+GitHub with the labels "enhancement" and "incomplete"
+(see [here][feature-requests]).
+
+[feature-requests]: https://github.com/phlummox/hup/issues?q=is%3Aissue+is%3Aclosed+label%3Aenhancement+label%3Aincomplete
+
+## Credits
+
+`hup` is a Haskellified version of [Oleg Grenrus's script][oleg],
+which is a stack-enabled version of [Eric Mertens's script][eric].
+
+[oleg]: http://web.archive.org/web/20210209123501/https://github.com/mstksg/binary-orphans/commit/3f106567260c1a9bb3063d49948201675876ad12.patch
+[eric]: http://web.archive.org/web/20210209124009/https://github.com/ekmett/lens/commit/12b08783a3e44d46b41553d8a57560c6e68cf7e1.patch
+
+
diff --git a/app/CmdArgs.hs b/app/CmdArgs.hs
new file mode 100644
--- /dev/null
+++ b/app/CmdArgs.hs
@@ -0,0 +1,228 @@
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-cse #-}
+{-# OPTIONS_GHC -fno-warn-missing-fields #-}
+{-# LANGUAGE CPP #-}
+
+#if __GLASGOW_HASKELL__ >= 804
+{-# OPTIONS_GHC -Wno-partial-fields #-}
+#endif
+
+module CmdArgs
+ (
+ isDoc
+ , isBuild
+ , isBoth
+ , isUp
+ , HupCommands(..)
+ , isUpload
+ , processArgs
+ )
+ where
+
+import Data.Version (showVersion)
+import Paths_hup (version)
+import System.Console.CmdArgs hiding(cmdArgs)
+import System.Environment (getArgs, withArgs)
+
+import qualified DefaultServerUrl
+
+import qualified System.Console.CmdArgs.Implicit
+
+cmdArgs :: Data a => a -> IO a
+cmdArgs = System.Console.CmdArgs.Implicit.cmdArgs
+
+isDoc :: HupCommands -> Bool
+isDoc cmd = case cmd of
+ Docbuild {} -> True
+ Docboth {} -> True
+ _ -> False
+
+isBuild :: HupCommands -> Bool
+isBuild cmd = case cmd of
+ Docbuild {} -> True
+ Packbuild {} -> True
+ _ -> False
+
+isBoth :: HupCommands -> Bool
+isBoth cmd = case cmd of
+ Docboth {} -> True
+ Packboth {} -> True
+ _ -> False
+
+isUp :: HupCommands -> Bool
+isUp cmd = case cmd of
+ Docup {} -> True
+ Packup {} -> True
+ _ -> False
+
+
+
+
+defaultServer :: String
+defaultServer = DefaultServerUrl.defaultServerUrl
+
+-- | Actions the program can perform
+data HupCommands =
+ Docbuild { verbose :: Bool
+ , executables :: Bool
+ , tests :: Bool
+ , internal :: Bool
+ ,haddockArgs :: String
+ ,quick :: Bool }
+ | Docboth { verbose :: Bool
+ , executables :: Bool
+ , tests :: Bool
+ , internal :: Bool
+ , haddockArgs :: String
+ , quick :: Bool
+ , server :: String
+ , candidate :: Bool
+ , user :: Maybe String
+ , password :: Maybe String }
+
+ | Packbuild { verbose :: Bool }
+
+ | Packup { verbose :: Bool
+ , server :: String
+ , candidate :: Bool
+ , user :: Maybe String
+ , password :: Maybe String
+ , file :: String }
+
+ | Packboth { verbose :: Bool
+ , server :: String
+ , candidate :: Bool
+ , user :: Maybe String
+ , password :: Maybe String
+ }
+
+ | Docup { verbose :: Bool
+ , server :: String
+ , candidate :: Bool
+ , user :: Maybe String
+ , password :: Maybe String
+ , file :: String }
+ deriving (Show, Eq, Data, Typeable, Ord)
+
+isUpload :: HupCommands -> Maybe HupCommands
+isUpload Docbuild {} = Nothing
+isUpload x = Just x
+
+-- Helpers for specifying metavariables etc. for
+-- arguments.
+
+{-# INLINE serverArg #-}
+serverArg :: Data val => val -> val
+serverArg x = x &= typ "URL"
+
+{-# INLINE userArg #-}
+userArg :: Data val => val -> val
+userArg x = x &= typ "USER"
+
+{-# INLINE passwdArg #-}
+passwdArg :: Data val => val -> val
+passwdArg x = x &= typ "PASSWORD"
+
+{-# INLINE fileArg #-}
+fileArg :: Data val => val -> val
+fileArg x = x &= typ "FILE"
+
+{-# INLINE verbArgs #-}
+verbArgs :: Data val => val -> val
+verbArgs x = x &= help "be verbose"
+
+-- commands that can be run
+
+packbuild :: HupCommands
+packbuild =
+ Packbuild
+ { verbose = verbArgs def
+ }
+ &= help "Build source distribution .tgz for a package."
+
+
+packup :: HupCommands
+packup =
+ Packup
+ { verbose = verbArgs def
+ ,server = serverArg defaultServer
+ ,candidate = def
+ ,file = fileArg def &= argPos 0
+ ,user = userArg Nothing
+ ,password = passwdArg Nothing }
+ &= help (unwords ["Upload FILE as a package (or"
+ ,"candidate package)."])
+
+packboth :: HupCommands
+packboth =
+ Packboth
+ { verbose = verbArgs def
+ ,server = serverArg defaultServer
+ ,candidate = def
+ ,user = userArg Nothing
+ ,password = passwdArg Nothing }
+ &= help (unwords ["Build source distribution .tgz and upload"
+ ,"as package (or candidate package)."])
+
+docbuild :: HupCommands
+docbuild =
+ Docbuild
+ { verbose = verbArgs def
+ ,executables = def &= help "Run haddock for Executables targets"
+ ,tests = def &= help "Run haddock for Test Suite targets"
+ ,internal = def &= help (unwords ["Run haddock for internal"
+ ,"modules and include all symbols"])
+ ,haddockArgs = def &= help "extra args to pass to haddock"
+ &= explicit
+ &= name "haddock-arguments"
+ &= typ "ARGS"
+ ,quick = def &= help (unwords ["quick build - don't build"
+ ,"docco for dependencies (links may"
+ ,"be broken)"])
+ }
+ &= help "Build documentation for a package."
+
+docup :: HupCommands
+docup =
+ Docup
+ { server = serverArg defaultServer
+ ,file = fileArg def &= argPos 0
+ }
+ &= help "Upload FILE as documentation."
+
+docboth :: HupCommands
+docboth =
+ Docboth
+ {}
+ &= help "Build and upload documentation for a package."
+
+-- Process command-line arguments
+processArgs :: IO HupCommands
+processArgs = do
+ args <- getArgs
+ -- If the user did not specify any arguments, pretend "--help" was given
+ (if null args then withArgs ["--help"] else id) proc
+
+ where
+ proc :: IO HupCommands
+ proc = cmdArgs $ -- commands that can be run, i.e. "modes"
+ modes [packbuild
+ ,packup
+ ,packboth
+ ,docbuild -- &= groupname "A"
+ ,docup -- &= groupname "B"
+ ,docboth ] -- &= groupname "C"]
+ &= help progHelp
+ &= program "hup"
+ &= summary ("hup v" ++ showVersion version)
+ &= helpArg [explicit, name "h", name "help"]
+
+ progHelp = unwords
+ ["Build and/or upload packages or documentation to a hackage server."
+ ,"A server url should be of the format PROTOCOL://SERVER[:PORT]/,"
+ ,"and defaults to", defaultServer, "if not specified.\n"
+ ,"\nA password can also be given in the HUP_HACKAGE_PASSWORD environment"
+ ,"variable instead of on the command line.\n", "\n'hup --help=all'"
+ ,"will give help for all commands." ]
+
diff --git a/app/DefaultServerUrl.hs b/app/DefaultServerUrl.hs
new file mode 100644
--- /dev/null
+++ b/app/DefaultServerUrl.hs
@@ -0,0 +1,16 @@
+
+module DefaultServerUrl
+ (
+ defaultServerUrl
+ )
+ where
+
+-- | The default hackage server URL.
+defaultServerUrl :: String
+defaultServerUrl = "https://hackage.haskell.org/"
+--defaultServerUrl = "http://localhost:8080/"
+
+
+
+
+
diff --git a/app/DocBuilding.hs b/app/DocBuilding.hs
new file mode 100644
--- /dev/null
+++ b/app/DocBuilding.hs
@@ -0,0 +1,213 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{- |
+
+Knowledge of the arcane and cryptic commands to be run to get
+haddock docs properly built.
+
+-}
+
+module DocBuilding
+ (
+ -- * given a 'HupCommand', what arguments are needed
+ verbosityArgs
+ , haddockExtraArgs
+ , cabalExtraArgs
+ -- * actions
+ , buildDependencyDocs
+ , cabalConfigure
+ , cabalHaddock
+ , doBuildTar
+ -- * top-level action
+ , buildDocs
+ -- * path utilities
+ , buildDir
+ )
+ where
+
+import Control.Exception.Lifted
+import Control.Monad.IO.Class ( MonadIO(..) )
+
+import Data.Text ( Text )
+import qualified Data.Text as T
+import Data.Monoid ( (<>) )
+import Data.Char (isSpace)
+
+import Prelude hiding (FilePath)
+import Shelly ( ReThrownException )
+import Shelly.Lifted
+
+import Distribution.Hup ( Package(..), buildTar )
+import CmdArgs (HupCommands(..))
+import qualified Stack
+
+{-# ANN module ("HLint: ignore Use list comprehension" :: String) #-}
+{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
+
+-- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m,
+-- 'MonadShControl' m@
+type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m)
+
+rstrip :: Text -> Text
+rstrip = T.dropWhileEnd isSpace
+
+
+-- | any arguments for cabal deriving from how verbose
+-- we've been asked to be
+verbosityArgs :: HupCommands -> [Text]
+verbosityArgs hc = if verbose hc then ["-v2"] else []
+
+-- | arguments to supply directly to haddock, such as "--executables",
+-- "--internal", or anything specified by the end user
+haddockExtraArgs :: HupCommands -> [Text]
+haddockExtraArgs hc =
+ let args = haddockArgs hc
+ in (if null args
+ then []
+ else ["--haddock-options=" <>T.pack(haddockArgs hc)])
+ ++ (if executables hc then ["--executables"] else [])
+ ++(if tests hc then ["--tests"] else [])
+ ++(if internal hc then ["--internal"] else [])
+
+-- | any arguments which need to be supplied to cabal,
+-- like "--enable-tests"
+cabalExtraArgs :: HupCommands -> [Text]
+cabalExtraArgs hc = if tests hc then ["--enable-tests"] else []
+
+
+-- | run haddock with "--only-dependencies"
+buildDependencyDocs :: MonadSh m => m ()
+buildDependencyDocs =
+ run_ "stack" ["haddock", "--only-dependencies"]
+
+-- | given a "base" dir, return the "dist" subdir
+-- where built stuff actually gets put.
+buildDir :: FilePath -> FilePath
+buildDir baseDir = baseDir "dist"
+
+-- | run "cabal configure" with appropriate args, prior to
+-- running "cabal haddock". cabal should be on path.
+--
+-- args: @cabalConfigure baseDir cabalExtraArgs verbosityArgs@.
+cabalConfigure
+ :: MonadShellish m =>
+ FilePath -> [Text] -> [Text] -> m ()
+cabalConfigure baseDir cabalExtraArgs verbosityArgs = do
+ let tt = toTextIgnore
+ snapshotpkgdb <- rstrip <$> silently (run "stack" ["path", "--snapshot-pkg-db"])
+ localpkgdb <- rstrip <$> silently (run "stack" ["path", "--local-pkg-db"])
+ run_ "cabal" $ ["configure", "--builddir="<> tt (buildDir baseDir),
+ "--package-db=clear", "--package-db=global",
+ "--package-db=" <> snapshotpkgdb,
+ "--package-db=" <> localpkgdb] ++ verbosityArgs
+ ++ cabalExtraArgs
+
+-- | run "cabal haddock" with appropriate args. Haddock
+-- should be on path.
+--
+-- args: @cabalHaddock baseDir verbosityArgs haddockExtraArgs@
+--
+cabalHaddock
+ :: MonadShellish m => FilePath -> [Text] -> [Text] -> m ()
+cabalHaddock baseDir verbosityArgs haddockExtraArgs = do
+ let tt = toTextIgnore
+ canHyperlink <- Stack.haddockCanHyperlinkSrc
+ let hyperlinkArgs = if canHyperlink
+ then ["--haddock-option=--hyperlinked-source"]
+ else []
+ run_ "cabal" $ ["haddock", "--builddir=" <> tt (buildDir baseDir),
+ "--html-location=/package/$pkg-$version/docs",
+ "--contents-location=/package/$pkg-$version"]
+ ++ hyperlinkArgs ++ verbosityArgs
+ ++ haddockExtraArgs
+
+
+-- | Tar up the html produced by haddock into a "-docs.tar.gz" file.
+-- Returns the path of the tar file that has been built.
+--
+-- args: @doBuildTar baseDir package@.
+doBuildTar :: MonadShellish m => FilePath -> Package -> m FilePath
+doBuildTar baseDir (Package pkg_ ver_) = do
+ let
+ pkg = T.pack pkg_
+ ver = T.pack ver_
+ fromPath = T.unpack . toTextIgnore
+ docTgz = fromPath $ baseDir (pkg<>"-"<>ver <> "-docs.tar.gz")
+ docDir = pkg <> "-" <> ver <> "-docs"
+ -- build tar using pure hs. or, if you have tar on system, could use:
+ -- run "tar" ["cvz", "-C", dir, "--format=ustar", "-f", docTgz,
+ -- pkg <> "-" <> ver <> "-docs" ]
+ liftIO $ buildTar docTgz (fromPath baseDir) [T.unpack docDir]
+ return $ fromText $ T.pack docTgz
+
+-- Shelly exceptions end up being (almost) endlessly wrappered IOErrors ...
+-- but here's a convenience function for catching what they look like at
+-- the top level.
+catch_sh_rethrown :: Sh a -> (ReThrownException SomeException -> Sh a) -> Sh a
+catch_sh_rethrown = catch
+
+-- | Build a documentation .tgz file.
+--
+-- A Haskellified version of
+-- phadej's script at
+--
+-- ,
+--
+-- which is a stack-enabled version of ekmett's script at
+--
+-- .
+--
+-- @stackBuildDocs baseDir pkg@ will build documentation in the
+-- directory @baseDir@.
+--
+-- Requires that stack, haddock and cabal be on the path.
+--
+-- Sample usage:
+--
+-- > :set -XOverloadedStrings
+-- > let p = Package "foo" "0.1"
+-- > shelly $ verbosely $ buildDocs "." p
+--
+-- When running from within ghci, you may have to unset some
+-- environment variables that have been set. Else cabal will complain
+-- about them.
+--
+-- > import System.Environment
+-- > import Control.Monad
+-- > mapM_ unsetEnv ["HASKELL_PACKAGE_SANDBOXES", "GHC_PACKAGE_PATH", "HASKELL_PACKAGE_SANDBOX", "STACK_EXE", "HASKELL_DIST_DIR"]
+--
+buildDocs
+ :: MonadShellish m =>
+ HupCommands -> FilePath -> Package -> m FilePath
+buildDocs hc tmpDir pkg =
+ do
+ unless (quick hc) $ do
+ echo "building dependency docs"
+ buildDependencyDocs
+ echo "configuring"
+ cabalConfigure tmpDir (verbosityArgs hc) (cabalExtraArgs hc)
+ echo "running haddock"
+ cabalHaddock tmpDir (verbosityArgs hc) (haddockExtraArgs hc)
+ echo "copying html files"
+ copyHtmlDir (toTextIgnore tmpDir) pkg
+ echo "building tar file"
+ doBuildTar tmpDir pkg
+ where
+ -- copy the html files from where haddock puts them to
+ -- somewhere we can tar them from.
+ copyHtmlDir :: MonadShellish m => Text -> Package -> m ()
+ copyHtmlDir baseDir (Package pkg_ ver_) = do
+ let pkg = T.pack pkg_
+ ver = T.pack ver_
+ srcDir = baseDir "dist" "doc" "html" pkg
+ tgtDir = baseDir (pkg <> "-" <> ver <> "-docs")
+ echo $ "copying from " <> toTextIgnore srcDir <> " to " <> toTextIgnore tgtDir
+ liftSh $ catch_sh_rethrown (errExit False $ cp_r srcDir tgtDir) $ \e -> do
+ echo $ T.unwords ["hup: Encountered exception trying to copy html"
+ , "documentation:", T.pack $ show e ]
+ quietExit 1
+
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,259 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+
+module Main
+ (
+ main
+ )
+ where
+
+import Prelude hiding (FilePath)
+
+import Control.Monad
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Control.Monad.Reader (MonadReader(..), runReaderT)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Except (ExceptT(..),runExceptT,throwE)
+
+import Data.Text ( Text )
+import qualified Data.Text as T
+import Data.Monoid ( (<>) )
+
+import Shelly.Lifted
+import System.IO (hSetBuffering, BufferMode( LineBuffering )
+ , stdout)
+--import qualified System.IO.Temp as Tmp
+
+import Distribution.Hup ( Package(..),IsDocumentation(..)
+ , IsCandidate(..),Auth(..),Upload(..)
+ , mkAuth
+ , readCabal, extractCabal
+ , parseTgzFilename'
+ , getUploadUrl)
+import CmdArgs (HupCommands(..), isUpload, processArgs
+ , isBuild, isBoth, isDoc)
+import DocBuilding (buildDocs)
+import SanityCheck (sanity)
+import qualified Stack
+import Upload (doUpload)
+
+
+
+
+
+-- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m,
+-- 'MonadShControl' m, 'MonadReader' 'HupCommands' m@
+type MonadHup m = (MonadIO m, MonadSh m, MonadShControl m, MonadReader HupCommands m)
+
+-- | Build documentation tgz, return an Upload value,
+-- return an Upload value, ready to be uploaded. (Or not, as desired.)
+--
+-- This installs cabal-install if it is not found in the snapshot
+-- binaries, and adds the path to the cabal executable, and to
+-- haddock, to the path.
+--
+-- Sample usage:
+--
+-- > import Distribution.Hup.Upload
+-- > :set -XOverloadedStrings
+-- > let p = Package "foo" "0.1"
+-- > let d = Docbuild { verbose = True }
+-- > upload <- shelly $ verbosely $ runReaderT (stackBuildDocs "." p) d
+-- > doUpload "http://localhost:8080" upload (mkAuth "myname" "mypass")
+--
+-- When running from within ghci, you may have to unset some
+-- environment variables that have been set.
+--
+-- > import System.Environment
+-- > import Control.Monad
+-- > mapM_ unsetEnv ["HASKELL_PACKAGE_SANDBOXES", "GHC_PACKAGE_PATH", "HASKELL_PACKAGE_SANDBOX", "STACK_EXE", "HASKELL_DIST_DIR"]
+stackBuildDocs :: MonadHup m => FilePath -> Package -> m Upload
+stackBuildDocs tmpDir pkg = do
+ hc <- ask
+ -- check paths for the tools we need
+ Stack.addHaddockPath
+ echo "checking for cabal"
+ haveCabal <- Stack.cabalInstalled
+ unless haveCabal $ do
+ echo "didn't find 'cabal' binary in snapshot directory - installing it"
+ Stack.installCabal
+ Stack.addCabalPath
+ -- build the tgz file
+ docTgz <- toTextIgnore <$> buildDocs hc tmpDir pkg
+ -- return an Upload value, ready to be uploaded. (Or not, as desired.)
+ return $ Upload pkg (T.unpack docTgz) Nothing IsDocumentation (isCand hc)
+
+
+-- | run "stack sdist" and copy tarball to current dir.
+--
+-- sample use - something like:
+--
+-- > let p = Package "foo" "0.1"
+-- > let d = Pacbuild { verbose = True }
+-- > shelly $ verbosely $ runReaderT (stackSourceDist p) d
+--
+stackSourceDist :: MonadHup m => Package -> m Upload
+stackSourceDist p@(Package pkg ver) = do
+ -- work out flags to call with ...
+ hc <- ask
+ run_ "stack" ["sdist"] -- if there are errors, just let them
+ -- be re-thrown
+ distDir <- Stack.extractPath =<< run "stack" ["path", "--dist-dir"]
+ let tgzFile = pkg <> "-" <> ver <> ".tar.gz"
+ cp (distDir tgzFile) "."
+ return $ Upload p tgzFile Nothing IsPackage (isCand hc)
+
+
+-- | if we have a username, then we need to get
+-- a password, either from the command-line or the env
+getAuth :: MonadSh m => HupCommands -> m (Maybe Auth)
+getAuth hc = runMaybeT $ do
+ hc <- MaybeT $ return $ isUpload hc
+ u <- MaybeT $ return $ user hc
+ case password hc of
+ Just p -> MaybeT $ return $ mkAuth u p
+ Nothing -> do x <- get_env "HUP_HACKAGE_PASSWORD"
+ case x of
+ Nothing -> terror "username specified, but no password"
+ Just p -> MaybeT $ return $ mkAuth u (T.unpack p)
+
+
+-- Use for "early return"
+data Done = Done
+ deriving (Show)
+
+type MonadDone m a = ExceptT Done m a
+
+runEarlyReturn :: Monad m => MonadDone m () -> m ()
+runEarlyReturn f =
+ either (const ()) id <$> runExceptT f
+
+isCand :: HupCommands -> IsCandidate
+isCand hc =
+ if candidate hc
+ then CandidatePkg
+ else NormalPkg
+
+-- | Look at a FILE command-line arg of something we've been asked to
+-- upload, & try uploading it.
+--
+-- Will throw exceptions if the file doesn't exist, or doesn't look
+-- like a .tar.gz file, or if we've been asked to upload docco &
+-- it looks like a source file.
+--
+-- If the upload fails due to a bad status, however, it should
+-- give a hopefully comprehensible message then end early.
+--
+-- todo: give nice error messages, rather than throwing exceptions
+-- in some cases?
+uploadTgz ::
+ (MonadSh m, MonadIO m, MonadReader HupCommands m) =>
+ IsDocumentation -> Text -> MonadDone m ()
+uploadTgz expectedType desc = do
+ hc <- ask
+ let fileName = file hc
+ fileName'' = T.pack fileName
+ candType = isCand hc
+ serverUrl = server hc
+ verb = verbose hc
+ (upType, Package pkg ver) <- let parsed = parseTgzFilename' fileName
+ in either (lift . terror) return parsed
+ when (upType /= expectedType) $
+ lift $ terror $ T.unwords ["Expected", desc, "file, got", fileName'']
+ -- if all is ok, do the upload.
+ let upload = Upload (Package pkg ver) (file hc) Nothing expectedType candType
+ auth <- lift $ getAuth hc
+ let url = getUploadUrl serverUrl upload
+ lift $ echo $ "uploading to " <> T.pack url
+ serverResponse <- liftIO $ doUpload serverUrl upload auth
+ let displayedMesg msg = "Uploaded successfully" <>
+ (if verb
+ then T.pack msg
+ else "")
+ case serverResponse of
+ Left err -> do lift $ echo $ "Error from server:\n" <> T.pack err
+ throwE Done
+ Right msg -> lift $ echo $ displayedMesg msg
+
+
+
+-- | Run a hup command (which contains details of server url to use,
+-- user authentication details, etc.)
+--
+-- sample usage:
+--
+-- > let d = Docbuild { verbose = True }
+-- > shelly $ verbosely $ runReaderT $ mainSh d
+mainSh :: MonadHup m => m ()
+mainSh = do
+ hc <- ask
+ --tmpBase <- liftIO $ Tmp.getCanonicalTemporaryDirectory
+ --tmpDir <- fromText . T.pack <$> liftIO (Tmp.createTempDirectory tmpBase "hup")
+ --do
+
+ -- * Bug intermittently occurred where this temp directory disappeared
+ -- partway thru mainSh running. Might've been caused by something
+ -- not being strict enough? This seems to fix it, so far *shrug*
+ withTmpDir $ \tmpDir -> do
+ !_ <- runEarlyReturn $ do
+ cabalConts <- liftIO readCabal
+ let packageName = extractCabal "name" cabalConts
+ packageVer = extractCabal "version" cabalConts
+ case hc of
+ Packup {} -> do uploadTgz IsPackage "package"
+ throwE Done
+ Docup {} -> do uploadTgz IsDocumentation "documentation"
+ throwE Done
+ (isBuild -> True) -> return () -- i.e. carry on.
+ (isBoth -> True) -> return ()
+ _ -> error "match error"
+ -- if still here, we've been asked to do a build.
+ uploadable <- do let p = Package packageName packageVer
+ buildRes <- case hc of
+ (isDoc -> True) -> lift $ stackBuildDocs tmpDir p
+ _ -> lift $ stackSourceDist p
+
+ let tgzFile = fromText $ T.pack $ fileToUpload buildRes
+
+ case hc of
+ Packbuild {} -> throwE Done -- build only
+ Docbuild {} -> lift (cp tgzFile ".") >>
+ throwE Done -- no need to upload,
+ -- only build requested
+ _ -> return buildRes
+ auth <- lift $ getAuth hc
+ let url = getUploadUrl (server hc) uploadable
+ lift $ echo $ "uploading to " <> T.pack url
+ response <- liftIO $ doUpload (server hc) uploadable auth
+ case response of
+ Left err -> do lift $ echo $ "Error from server:\n'" <> T.pack err
+ throwE Done
+ Right msg -> lift $ do echo "Uploaded successfully"
+ echo $ "mesg was: " <> T.pack msg
+ return ()
+
+
+
+main :: IO ()
+main = do
+ hSetBuffering stdout LineBuffering
+ hupCommand <- sanity =<< processArgs
+ let verbosify = if verbose hupCommand
+ then verbosely
+ else id
+ shelly $
+ verbosify $
+ runReaderT mainSh hupCommand
+ return ()
+
+
+
diff --git a/app/SanityCheck.hs b/app/SanityCheck.hs
new file mode 100644
--- /dev/null
+++ b/app/SanityCheck.hs
@@ -0,0 +1,59 @@
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SanityCheck
+ (
+ sanity
+ )
+ where
+
+import Control.Monad
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Except (ExceptT(..),runExceptT, throwE)
+
+import Data.Monoid ( (<>) )
+import Shelly (unlessM)
+import System.Directory (makeAbsolute,doesFileExist )
+import System.Exit
+
+import CmdArgs (HupCommands(..), isBoth, isBuild, isUp)
+
+-- TODO:
+-- - does server look like a server?
+-- - do we need to be careful of treating URLs and filepaths
+-- as potentially bad?
+-- - will ignore the sensibleness of haddockArgs, users can pass
+-- what they like
+-- - does the file look like a file?
+
+-- | Run some sanity checks over a HupCommand, e.g. confirm
+-- any files it refers to actually exist.
+sanity :: HupCommands -> IO HupCommands
+sanity !hc = do
+ putStrLn "running sanity checks"
+ let !sanityTests = [fileSanity] -- TODO: add more sanity tests here <<
+ -- compose them
+ !composedSanityTests = foldl (>=>) return sanityTests
+ !res <- runExceptT $ composedSanityTests hc
+ case res of
+ Left err -> do print err
+ exitFailure
+ Right ok -> return ok
+
+-- | sanity test that file exists.
+fileSanity
+ :: MonadIO m => HupCommands -> ExceptT String m HupCommands
+fileSanity hc = case hc of
+ -- ignore things without a file arg
+ (isBuild -> True) -> return hc
+ (isBoth -> True) -> return hc
+ (isUp -> True) -> do let f = file hc
+ absF <- liftIO $ makeAbsolute f
+ unlessM ( liftIO $ doesFileExist absF ) $
+ throwE $ "Cannot find a file '" <> f <> "'"
+ let hc' = hc { file = absF }
+ return hc'
+ _ -> error "match error, shouldn't be possible"
+
diff --git a/app/Stack.hs b/app/Stack.hs
new file mode 100644
--- /dev/null
+++ b/app/Stack.hs
@@ -0,0 +1,115 @@
+
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+
+{- |
+
+Abstract over some of stack's functionality.
+
+-}
+
+module Stack
+ (
+ haddockCanHyperlinkSrc
+ , addHaddockPath
+ , cabalInstalled
+ , installCabal
+ , addCabalPath
+ , extractPath
+ )
+ where
+
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Shelly.Lifted
+import Data.Maybe
+import Data.Text ( Text )
+import qualified Data.Text as T
+import Prelude hiding (FilePath)
+import Control.Monad
+import Data.Char (isSpace)
+--import Control.Monad.Fail ( MonadFail )
+--import Control.Monad.Trans.Maybe (runMaybeT)
+
+
+-- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m,
+-- 'MonadShControl' m
+type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m)
+
+-- | @haddockCanHyperlinkSrc@ tells you whether a version of
+-- haddock is on the path that can do source hyperlinking.
+--
+-- (implementation: versions of haddock that can't do source hyperlinking
+-- return a non-zero status code if you pass "--hyperlinked-source".)
+haddockCanHyperlinkSrc :: MonadShellish m => m Bool
+haddockCanHyperlinkSrc = errExit False $ do
+ silently $ run_ "haddock" ["--hyperlinked-source"]
+ (==0) <$> lastExitCode
+
+rstrip :: Text -> Text
+rstrip = T.dropWhileEnd isSpace
+
+-- | @onPath prog@ tells you whether the program
+-- is on the path
+onPath :: MonadSh f => FilePath -> f Bool
+onPath prog =
+ isJust <$> which prog
+
+-- | check that stack is on path, or die.
+stackIsOnPath :: MonadSh m => m ()
+stackIsOnPath =
+ unlessM (onPath "stack") $ do
+ echo "Couldn't find stack on path - do you need to install stack?"
+ quietExit 1
+
+-- | check that ghc can be executed, using stack, or die.
+ghcIsOnPath :: MonadShellish m => m ()
+ghcIsOnPath = do
+ errExit False $ run_ "stack" ["exec", "--", "which", "ghc"]
+ exitCode <- lastExitCode
+ when (exitCode /= 0) $
+ terror "Something is terribly wrong - couldn't get a path for ghc. exiting"
+
+
+-- | trim, convert, canonicalize a path given as Text
+-- (e.g. from 'run').
+extractPath :: MonadSh m => Text -> m FilePath
+extractPath = canonicalize <=< (return . fromText . rstrip)
+
+-- | get the directory containing ghc and haddock
+ghcDir :: MonadSh m => m FilePath
+ghcDir =
+ extractPath =<< run "stack" ["path", "--compiler-bin"]
+
+-- | get the snapshot binaries directory, where programs
+-- are installed
+snapshotBinDir :: MonadShellish m => m FilePath
+snapshotBinDir =
+ ( "bin") <$> (extractPath =<< silently (run "stack" ["path", "--snapshot-install-root"]))
+
+
+-- | whether "cabal" is installed in the current snapshot.
+cabalInstalled :: MonadShellish m => m Bool
+cabalInstalled = do
+ binDir <- snapshotBinDir
+ sub $ do
+ setenv "PATH" (toTextIgnore binDir)
+ onPath "cabal"
+
+-- | Install a @cabal@ executable, from the package @cabal-install@,
+-- into the package snapshot.
+installCabal :: MonadShellish m => m ()
+installCabal =
+ verbosely $ run_ "stack" ["build", "--no-copy-bins", "cabal-install"]
+
+-- | prepend haddock's directory to the path
+addHaddockPath :: MonadSh m => m ()
+addHaddockPath = do
+ haddockDir <- extractPath =<< run "stack" ["path", "--compiler-bin"]
+ prependToPath haddockDir
+
+-- | prepend cabal's directory to the path
+addCabalPath :: MonadShellish m => m ()
+addCabalPath =
+ snapshotBinDir >>= prependToPath
+
diff --git a/app/Types.hs b/app/Types.hs
new file mode 100644
--- /dev/null
+++ b/app/Types.hs
@@ -0,0 +1,31 @@
+
+module Types
+ (
+ Server(..)
+ , GlobalOpts(..)
+ , PartialServer
+ )
+ where
+
+
+import Distribution.Hup.Upload
+
+
+data Server = Server { serverURL :: String
+ ,serverAuth :: Maybe Auth }
+ deriving (Show, Eq)
+
+data GlobalOpts = GlobalOpts { optVerbose :: Bool
+ ,optPackageName :: Maybe String
+ ,optVersion :: Maybe String
+ ,optIsCandidate :: Bool }
+ deriving (Show, Eq)
+
+
+-- | A server url, and possibly username and/or password.
+-- We may need to obtain more.
+type PartialServer = (String, Maybe String, Maybe String)
+
+
+
+
diff --git a/app/Upload.hs b/app/Upload.hs
new file mode 100644
--- /dev/null
+++ b/app/Upload.hs
@@ -0,0 +1,92 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module Upload (
+ doUpload
+) where
+
+import Control.Monad
+import Control.Monad.Trans.Except (runExcept,throwE)
+import Data.ByteString.Lazy.Char8 (unpack)
+import qualified Data.ByteString.Lazy as BS
+import Data.ByteString.Lazy (ByteString)
+import Data.List (maximumBy)
+import Data.Ord (comparing)
+import Text.HTML.TagSoup (parseTags, Tag(..),innerText, (~/=))
+
+import Distribution.Hup.Upload (Upload(..), Response(..), Auth(..)
+ ,buildRequest, sendRequest)
+import Distribution.Hup.Parse (rstrip, lstrip,takeWhileEnd )
+
+-- | do an upload.
+doUpload :: String -> Upload -> Maybe Auth -> IO (Either String String)
+doUpload server upl userAuth = do
+ req <- buildRequest server upl userAuth
+ maybeResp <- sendRequest req
+ case maybeResp of
+ Left exception -> return $ Left $
+ "Request failed with a network exception: " ++ show exception
+ Right resp -> return $ displayResponse resp
+
+
+-- | Turn a 'Response' into some sort of hopefully useful error message
+-- if it wasn't successful.
+--
+-- TODO: give option of displaying successfully returned html,
+-- if verbose, perhaps
+displayResponse :: Response -> Either String String
+displayResponse resp = runExcept $ do
+ let (Response code mesg ctype body) = resp
+ codeIsBad = code < 200 || code >= 300
+ bodyMesg = case () of
+ _ | "text/html" `BS.isPrefixOf` ctype -> unwords ["probable html body"
+ ,"is:\n", probableBody body]
+ | "text/plain" `BS.isPrefixOf` ctype -> unwords ["text body is:\n"
+ , unpack body]
+ | otherwise -> unwords ["body was:\n"
+ , show body]
+ when codeIsBad $
+ throwE $ "Request failed, status code was " ++ show code
+ ++ "status message was: " ++ unpack mesg
+ ++ ", " ++ bodyMesg
+ -- else code is good ...
+ return $ unwords ["Request succeeded with status code", show code
+ , "status message:", unpack mesg] -- , bodyMesg]
+
+-- | drop blank lines, and collapse spaces within a line
+collapseWhitespace :: String -> String
+collapseWhitespace s =
+ let ls = lines s
+ wordsAndBack = unwords . words
+ in unlines $ filter (not . null) $ map wordsAndBack ls
+
+
+-- | try and grab what's probably the body of an html page &
+-- extract the text. Our rule of thumb is, it's the bigger of the set of tags
+-- coming from end to beginning that aren't obviously headers,
+-- OR the tag labelled as body.
+--
+-- (some 404 pages don't bother to include a "body" tag)
+probableBody :: ByteString -> String
+probableBody bod =
+ let
+ toString :: [Tag ByteString] -> String
+ toString = rstrip . lstrip . unpack . innerText
+ headerTags :: [String]
+ headerTags = ["