hup 0.3.0.2 → 0.3.0.3
raw patch · 49 files changed
+2393/−2178 lines, 49 filesdep +lifted-basedep +scottydep −simpledep −simple-templatesdep ~basedep ~cmdargsdep ~mtl
Dependencies added: lifted-base, scotty
Dependencies removed: simple, simple-templates
Dependency ranges changed: base, cmdargs, mtl, shelly, text
Files
- ChangeLog.md +18/−0
- README.md +223/−0
- app/CmdArgs.hs +228/−0
- app/DefaultServerUrl.hs +16/−0
- app/DocBuilding.hs +213/−0
- app/Main.hs +259/−0
- app/SanityCheck.hs +59/−0
- app/Stack.hs +115/−0
- app/Types.hs +31/−0
- app/Upload.hs +92/−0
- hup.cabal +54/−40
- lib/Distribution/Hup.hs +0/−46
- lib/Distribution/Hup/BuildTar.hs +0/−23
- lib/Distribution/Hup/Parse.hs +0/−168
- lib/Distribution/Hup/Types.hs +0/−38
- lib/Distribution/Hup/Upload.hs +0/−256
- src-doctest/DocTest.hs +0/−7
- src-hspec-test/Distribution/Hup/Parse/Test.hs +0/−66
- src-hspec-test/Distribution/Hup/ParseSpec.hs +0/−28
- src-hspec-test/Distribution/Hup/Upload/MockWebApp.hs +0/−73
- src-hspec-test/Distribution/Hup/Upload/Test.hs +0/−111
- src-hspec-test/Distribution/Hup/UploadSpec.hs +0/−123
- src-hspec-test/Distribution/Hup/WebTest.hs +0/−83
- src-hspec-test/Spec.hs +0/−1
- src/CmdArgs.hs +0/−209
- src/CmdArgs/PatchHelp.hs +0/−112
- src/DefaultServerUrl.hs +0/−13
- src/Distribution/Hup.hs +44/−0
- src/Distribution/Hup/BuildTar.hs +26/−0
- src/Distribution/Hup/Parse.hs +167/−0
- src/Distribution/Hup/Types.hs +44/−0
- src/Distribution/Hup/Upload.hs +257/−0
- src/DocBuilding.hs +0/−207
- src/Main.hs +0/−258
- src/SanityCheck.hs +0/−64
- src/Stack.hs +0/−107
- src/Types.hs +0/−25
- src/Upload.hs +0/−92
- stack-lts-14.yaml +10/−0
- stack-lts-3.yaml +3/−20
- stack-lts-7.yaml +0/−8
- test-doctest/DocTest.hs +7/−0
- test-hspec/Distribution/Hup/Parse/Test.hs +72/−0
- test-hspec/Distribution/Hup/ParseSpec.hs +33/−0
- test-hspec/Distribution/Hup/Upload/MockWebApp.hs +53/−0
- test-hspec/Distribution/Hup/Upload/Test.hs +112/−0
- test-hspec/Distribution/Hup/UploadSpec.hs +154/−0
- test-hspec/Distribution/Hup/WebTest.hs +98/−0
- test-hspec/Spec.hs +5/−0
ChangeLog.md view
@@ -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.
+ README.md view
@@ -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+<https://hackage.haskell.org/> 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++<!--+ vim: syntax=markdown+-->
+ app/CmdArgs.hs view
@@ -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." ]+
+ app/DefaultServerUrl.hs view
@@ -0,0 +1,16 @@++module DefaultServerUrl+ (+ defaultServerUrl+ )+ where++-- | The default hackage server URL.+defaultServerUrl :: String+defaultServerUrl = "https://hackage.haskell.org/"+--defaultServerUrl = "http://localhost:8080/"+++++
+ app/DocBuilding.hs view
@@ -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+--+-- <https://github.com/phadej/binary-orphans/blob/master/hackage-docs.sh>,+--+-- which is a stack-enabled version of ekmett's script at+--+-- <https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh>.+--+-- @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+
+ app/Main.hs view
@@ -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 ()+++
+ app/SanityCheck.hs view
@@ -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"+
+ app/Stack.hs view
@@ -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+
+ app/Types.hs view
@@ -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)+ +++
+ app/Upload.hs view
@@ -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 = ["<style>", "<header>", "<title>", "<meta>"]+ bodyTag :: String+ bodyTag = "<body>"++ parsedBod = parseTags bod+ notHeader t = all (t ~/=) headerTags + notHeaderBits = toString $ tail $ takeWhileEnd notHeader parsedBod+ possBodyBits = toString $ dropWhile (~/= bodyTag) parsedBod++ probBod = maximumBy (comparing length) [notHeaderBits, possBodyBits]++ in collapseWhitespace probBod++++
hup.cabal view
@@ -1,27 +1,43 @@ name: hup-version: 0.3.0.2-synopsis: Upload packages or documentation to a hackage server+version: 0.3.0.3+synopsis: Upload packages and/or documentation to a hackage server description:- Upload packages or documentation to a hackage server+ Command-line application (plus an associated library) for uploading+ Haskell packages or documentation to a hackage server. .- See the README for details+ Some sample command invocations:+ @/hup packbuild/@ builds a source distribution @.tgz@+ file, ready for uploading; @/hup packup somefile.tgz/@+ uploads it to a hackage server (<https://hackage.haskell.org/>,+ by default); and @/hup packboth/@ combines both steps.+ .+ Flags like @/[-c|--candidate]/@ allow you to upload a+ candidate package instead.+ .+ Requires that @stack@ (<https://www.haskellstack.org>) be installed.+ .+ See the README for further details (at <https://github.com/phlummox/hup#readme>) homepage: https://github.com/phlummox/hup license: BSD2 license-file: LICENSE author: phlummox maintainer: phlummox2@gmail.com-copyright: phlummox 2016-2020, others where indicated+copyright: phlummox 2016-2021, others where indicated category: Distribution, Web, Documentation build-type: Simple-tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2+tested-with: GHC == 8.2.2, GHC == 8.6.5+ -- until shelly is fixed, more recent+ -- GHCs/versions of base won't build --+ -- see https://github.com/phlummox/hup/issues/7 cabal-version: >=1.10 extra-source-files: ChangeLog.md+ , README.md , stack-lts-3.yaml- , stack-lts-7.yaml , stack-lts-11.yaml+ , stack-lts-14.yaml source-repository head type: git@@ -30,15 +46,7 @@ Flag EnableWebTests Description: Enable tests that do a (pretty minimal) check by running an actual Warp web server. (Slower to build and run than other tests.)- Default: False- Manual: True--Flag PatchHelpMessage- Description:- Use patched version of cmdargs-0.10.14.1 with more informative help- message. The patched version will need to be pulled from github- (or a stack.yaml file must point to it) - see stack.yaml for details.- Default: False+ Default: True Manual: True Flag ExtraGhcWarnings@@ -57,7 +65,7 @@ library- hs-source-dirs: lib+ hs-source-dirs: src exposed-modules: Distribution.Hup , Distribution.Hup.BuildTar@@ -65,15 +73,16 @@ , Distribution.Hup.Types , Distribution.Hup.Upload build-depends:- base >= 4.7 && < 5+ base >= 4.8 && < 5 , bytestring , directory , filepath , http-client , http-client-tls , http-types- , mtl+ , mtl >= 2.2.1 , split+ , text < 2.0 , tar , zlib default-language: Haskell2010@@ -97,14 +106,18 @@ -fwarn-incomplete-uni-patterns -fno-warn-type-defaults -fwarn-tabs+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies executable hup- hs-source-dirs: src+ hs-source-dirs: app main-is: Main.hs other-modules: CmdArgs- , CmdArgs.PatchHelp , DefaultServerUrl , Paths_hup , SanityCheck@@ -112,23 +125,21 @@ , Upload , Stack , DocBuilding- if flag(PatchHelpMessage)- other-modules: CmdArgs.PatchHelp- cpp-options: -DPATCH_HELP- build-depends: cmdargs == 0.10.14.1- else- build-depends: cmdargs default-language: Haskell2010 build-depends: base , bytestring , directory+ , lifted-base , mtl- , shelly >= 1.6.6+ -- avoid versions of shelly that don't+ -- build on Windows - see https://github.com/phlummox/hup/issues/7+ , shelly >= 1.6.6 && < 1.8.0 , tagsoup , text , transformers , hup+ , cmdargs ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -152,11 +163,16 @@ -fwarn-incomplete-uni-patterns -fno-warn-type-defaults -fwarn-tabs+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies test-suite hup-spec type: exitcode-stdio-1.0- hs-source-dirs: src-hspec-test+ hs-source-dirs: test-hspec main-is: Spec.hs build-depends: base@@ -169,20 +185,13 @@ , hspec , hspec-core , QuickCheck- , simple+ , scotty , temporary+ , text , transformers , wai , wai-extra- if impl(ghc < 8.4.4)- build-depends:- -- simple-templates 0.9.0.0 has broken bounds.- -- (<https://github.com/alevy/simple/issues/25>)- -- It states bounds on base of "< 6",- -- but the code only seems to build with- -- base >= 4.11.1.0 / ghc >= 8.4.4.- simple-templates < 0.9.0.0-+ , mtl ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -206,6 +215,11 @@ -fwarn-incomplete-uni-patterns -fno-warn-type-defaults -fwarn-tabs+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies default-language: Haskell2010 other-modules: Distribution.Hup.WebTest@@ -233,7 +247,7 @@ -- a bug in doctest, who knows test-suite hup-doctest type: exitcode-stdio-1.0- hs-source-dirs: src-doctest+ hs-source-dirs: test-doctest main-is: DocTest.hs if !(flag(BuildStackBasedTests)) buildable: False
− lib/Distribution/Hup.hs
@@ -1,46 +0,0 @@---- {-# OPTIONS_HADDOCK hide, prune #-}--{- |- Bits and pieces for building and uploading source or documentation .tar files- for Hackage, intended to make it easy to write your own Haskell - programs/scripts for managing uploads.-- This is the main entry-point to look at, and more low-level functions are- available in the other modules.--}--module Distribution.Hup -(--- -- | module hup- module Distribution.Hup --- * Finding and parsing Cabal files - , findCabal- , readCabal- , extractCabal--- * Parsing .tgz file names- , parseTgzFilename- , parseTgzFilename'--- * Building tar files- , buildTar--- * Uploading- , getUploadUrl- , mkAuth- , postPkg- , putDocs- , buildRequest- , sendRequest--- * Types- , IsCandidate(..)- , IsDocumentation(..) - , Package(..) - , Upload(..)- , Auth(..)-)- where---import Distribution.Hup.BuildTar -import Distribution.Hup.Parse-import Distribution.Hup.Upload-
− lib/Distribution/Hup/BuildTar.hs
@@ -1,23 +0,0 @@--{- | Build tar files---}--module Distribution.Hup.BuildTar where---import Codec.Archive.Tar as Tar (write, pack)-import qualified Codec.Compression.GZip as GZ-import Data.ByteString.Lazy as BS hiding (pack)-import Prelude hiding (read)----- | @buildTar tarFileName baseDir paths@ ---- create a gz-compressed tar file with name tarFileName,--- with files in it from baseDir, "paths" being the files & directories--- to archive, relative to baseDir.-buildTar :: FilePath -> FilePath -> [FilePath] -> IO ()-buildTar tarFileName baseDir paths = - BS.writeFile tarFileName . GZ.compress . write =<< pack baseDir paths --
− lib/Distribution/Hup/Parse.hs
@@ -1,168 +0,0 @@--{-| --extract info from cabal files and .tgz names.---}--module Distribution.Hup.Parse (- module Distribution.Hup.Parse- , module Distribution.Hup.Types -)where--import Control.Monad.Except (MonadError(..),when)--import Data.Char (isDigit, toLower, isSpace)-import Data.List (dropWhileEnd,isSuffixOf,stripPrefix- ,intercalate)-import Data.List.Split (splitOn)--import Data.Maybe (listToMaybe)-import Data.String-import System.Directory (getDirectoryContents)-import System.FilePath (splitExtension, splitFileName, takeExtension)--import Distribution.Hup.Types (IsCandidate(..), IsDocumentation(..) - ,Package(..), Upload(..) )----- | strip whitespace from end--- --- >>> rstrip "abcd \t\n\r"--- "abcd"-rstrip :: String -> String-rstrip = dropWhileEnd isSpace ---- | strip whitespace from beginning--- --- >>> lstrip "\t\n\r abcd"--- "abcd"-lstrip :: String -> String-lstrip = dropWhile isSpace ---- | Replace a subsequence everywhere it occurs. The first argument must--- not be the empty list.------ from NDM's <https://hackage.haskell.org/package/extra-1.5.1 extra-1.5.1>------ >>> replace "el" "_" "Hello Bella" == "H_lo B_la"--- True--- >>> replace "el" "e" "Hello" == "Helo"--- True------ > \xs ys -> not (null xs) ==> replace xs xs ys == ys--- > replace "" "e" "Hello" == undefined-replace :: Eq a => [a] -> [a] -> [a] -> [a]-replace [] _ _ = error "Extra.replace, first argument cannot be empty"-replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs-replace from to (x:xs) = x : replace from to xs-replace _from _to [] = []---- | Like 'Data.List.dropWhileEnd', but for 'Data.List.take'.------ (taken from filepath-1.4.1.1)------ >>> takeWhileEnd (< 10) [1, 2, 10, 3, 4, -3]--- [3,4,-3]-takeWhileEnd :: (a -> Bool) -> [a] -> [a]-takeWhileEnd p = reverse . takeWhile p . reverse---- | like 'Data.List.span', but from the end------ >>> spanEnd (< 3) [4,3,2,1,4,3,2,1] --- ([4,3,2,1,4,3],[2,1])--- >>> spanEnd (< 9) [1,2,3]--- ([],[1,2,3])--- >>> spanEnd (< 0) [1,2,3] --- ([1,2,3],[])-spanEnd :: (a -> Bool) -> [a] -> ([a], [a])-spanEnd p xs = (dropWhileEnd p xs, takeWhileEnd p xs)----- | like 'Data.List.break', but from the end------ >>> breakEnd (> 3) [4,3,2,1,4,3,2,1] --- ([4,3,2,1,4],[3,2,1])--- >>> breakEnd (< 9) [1,2,3] --- ([1,2,3],[])--- >>> breakEnd (> 9) [1,2,3] --- ([],[1,2,3])-breakEnd :: (a -> Bool) -> [a] -> ([a], [a])-breakEnd p = spanEnd (not . p)----- | if there's a .cabal file in the current dir, return its file name.------ from NDM's <https://hackage.haskell.org/package/neil-0.10 neil-0.10> -findCabal :: IO (Maybe Prelude.FilePath)-findCabal = do- x <- getDirectoryContents "."- return $ listToMaybe $ filter ((==) ".cabal" . takeExtension) x---- | find & read contents of Cabal file from current dir, if it exists.--- else returns empty string.------ from NDM's <https://hackage.haskell.org/package/neil-0.10 neil-0.10> -readCabal :: IO String-readCabal = do- file <- findCabal- case file of- Nothing -> return []- Just file -> readFile file----- | @extractCabal fieldName cabalConts@:--- extract contents of field named `fieldName` from a Cabal file string.------ field name is case-insensitive [folded to lowercase]------ from NDM's <https://hackage.haskell.org/package/neil-0.10 neil-0.10> -extractCabal :: String -> String -> String-extractCabal find = f . words . replace ":" " : "- where- f (name:":":val:_) | map toLower find == map toLower name = val- f (_x:xs) = f xs- f [] = error "Failed to find the Cabal key " ++ find---- | Inspect the name of a .tar.gz file to work out the package name --- and version it's for, and whether it is for documentation or a package.-parseTgzFilename- :: (IsString s, MonadError s m) => - Prelude.FilePath -> m (IsDocumentation, Package)-parseTgzFilename f = do - let (base, ext) = splitExtension f- ext `shouldBe` ".gz"- (base, ext) <- return $ splitExtension base - ext `shouldBe` ".tar"- base <- return $ snd $ splitFileName base- --let isDocco = if "-docs" `isSuffixOf` base- -- then IsDocumentation - -- else IsPackage- (base, isDocco) <- return $ if "-docs" `isSuffixOf` base- then let base' = intercalate "-" $ - init $ splitOn "-" base- in (base', IsDocumentation)- else (base, IsPackage)- let (pkg, ver) = spanVersion base- pkg <- return $ dropWhileEnd (=='-') pkg- return (isDocco, Package pkg ver)-- where- ext `shouldBe` expected = - when (ext /= expected) $- throwError $ fromString $ unwords ["Expected filename with extension"- ,"'.tar.gz', but got", f]- spanVersion = spanEnd (\x -> isDigit x || x == '.')---- | 'parseTgzFilename'' specialized to 'Data.Either.Either'.------ >>> (parseTgzFilename' "foo-bar-baz-0.1.0.0.2.3.0.1.tar.gz") :: Either String (IsDocumentation, Package)--- Right (IsPackage,Package {packageName = "foo-bar-baz", packageVersion = "0.1.0.0.2.3.0.1"})-parseTgzFilename'- :: (IsString s) => - Prelude.FilePath -> Either s (IsDocumentation, Package)-parseTgzFilename' = parseTgzFilename ----
− lib/Distribution/Hup/Types.hs
@@ -1,38 +0,0 @@---{-| --types useful package-wide---}--module Distribution.Hup.Types-where--import qualified Data.ByteString.Lazy as L---- | whether a package is a normal one or a candidate-data IsCandidate = NormalPkg | CandidatePkg- deriving (Show, Eq, Read)---- | are we uploading a package or just docs-data IsDocumentation = IsPackage | IsDocumentation- deriving (Show, Eq, Read)---- | name and version of a package-data Package = Package { packageName :: String- ,packageVersion :: String } - deriving (Show, Eq, Read)------ | Bundle together information useful for an upload.-data Upload = - Upload { package :: Package -- ^ package name & version- ,fileToUpload :: FilePath -- ^ file being uploaded- ,fileConts :: Maybe L.ByteString -- ^ file conts- ,uploadType :: IsDocumentation -- ^ docco or package - ,isCandidate :: IsCandidate -- ^ candidate or not- } deriving (Show, Eq)--
− lib/Distribution/Hup/Upload.hs
@@ -1,256 +0,0 @@--{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE CPP #-}--{-|--Handle uploading to a hackage server, using the @HTTP@ API described-in the-<https://hackage.haskell.org/api Hackage server documentation>.---}--module Distribution.Hup.Upload (- module Distribution.Hup.Upload- , module Distribution.Hup.Types- , Auth(..)-)-where--import Control.Monad-import qualified Data.ByteString.Builder as Bu-import Data.List (dropWhileEnd)-import Data.Maybe (fromJust)-import Data.ByteString.Char8 (pack,ByteString )-import qualified Data.ByteString.Lazy.Char8 as LBS-import qualified Data.ByteString.Lazy as L (ByteString)-import Data.Monoid ( (<>) )-import qualified Network.HTTP.Client as C-import Network.HTTP.Client (requestHeaders, Request, RequestBody(..)- ,method, requestBody, responseHeaders- ,responseStatus)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified Network.HTTP.Types as T-import Network.HTTP.Client.MultipartFormData- (formDataBody,partFileRequestBodyM- ,Part)--import Distribution.Hup.Types--- for re-export--import Control.Exception---#if MIN_VERSION_http_client(0,4,30)-parseRequest :: String -> IO Request-parseRequest = C.parseRequest-#else--parseRequest :: String -> IO Request-parseRequest =- fmap noThrow . C.parseUrl- where- noThrow req = req { C.checkStatus = \_ _ _ -> Nothing }-#endif------ | Alias for <https://hackage.haskell.org/package/http-client http-client's>--- 'Network.HTTP.Client.Response' type.-type HResponse = C.Response---- | Username and password for HTTP basic access authentication.-data Auth = Auth { authUser :: ByteString- , authPassword :: ByteString }- deriving (Eq, Show)---- | Options that can be applied to a Request.--- (e.g. to add standard headers, etc.)------ Can just use 'defaultOptions'.-newtype Options = Options (Request -> Request)--- deriving Show------ | returns default options to use with--- a request.------ We try to request plain text where possible;--- and we allow non-success statuses to still return normally--- (rather than throwing an exception)-defaultOptions :: Maybe Auth -> Options-defaultOptions mAuth =- case mAuth of- Nothing -> Options id- Just (Auth user pass) -> Options $ modify . C.applyBasicAuth user pass-- where- modify :: Request -> Request- modify x = x {- requestHeaders = ("User-Agent", "haskell hup-0.1.0.0")- : ("Accept", "text/plain")- : requestHeaders x- }------ | pack a name and password into an 'Auth' structure------ >>> mkAuth "myname" "mypassword"--- Just (Auth {authUser = "myname", authPassword = "mypassword"})-mkAuth :: String -> String -> Maybe Auth-mkAuth name password =- Just $ Auth (pack name) (pack password)---- | work out what URL to upload a .tgz file to.--- @getUploadUrl server upload@ returns a URL.------ >>> getUploadUrl "http://localhost:8080/" $ Upload (Package "foo" "0.1.0.0") "./foo-0.1.0.0.tar.gz" Nothing IsDocumentation CandidatePkg--- "http://localhost:8080/package/foo-0.1.0.0/candidate/docs"-getUploadUrl- :: String -> Upload -> String-getUploadUrl server upl =--- TODO:--- handle Yackage as well?--- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs- let- -- we are permissive, and drop any extra trailing slashes on server.- serverUrl = dropWhileEnd (=='/') server- (Upload (Package pkgName pkgVer) _filePath _fileConts uploadType pkgType ) = upl- in case uploadType of- IsPackage -> case pkgType of- NormalPkg -> serverUrl <>"/packages/"- CandidatePkg -> serverUrl <>"/packages/candidates/"- IsDocumentation ->- case pkgType of- NormalPkg -> serverUrl <> "/package/" <> pkgName- <> "-" <> pkgVer <> "/docs"- CandidatePkg -> serverUrl <> "/package/" <> pkgName- <> "-" <> pkgVer- <> "/candidate/docs"---- | @buildRequest serverUrl upl userAuth@ - create an HTTP request--- for uploading some package (details--- packed into @upl@) to the server at @serverUrl@, using--- the credentials in @userAuth@.------ e.g. usage:------ > let p = Package "foo" "0.1.0.0"--- > let u = Upload p "./foo-0.1.0.0.tar.gz" Nothing IsDocumentation CandidatePkg--- > req <- buildRequest "http://localhost:8080/" u (mkAuth "tmp" "tmp")--- > sendRequest req-buildRequest :: String -> Upload -> Maybe Auth -> IO Request-buildRequest serverUrl upl userAuth =--- TODO:--- handle Yackage as well?--- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs- let (Upload _ filePath fileConts uploadType _pkgType ) = upl- in case uploadType of- IsPackage -> do- let url = getUploadUrl serverUrl upl- postPkg url filePath fileConts userAuth- IsDocumentation -> do- let url = getUploadUrl serverUrl upl- putDocs url filePath fileConts userAuth---- | Send an HTTP request and get the response (or an exception)-sendRequest :: Request -> IO (Either C.HttpException Response)-sendRequest req =- do- man <- C.newManager tlsManagerSettings- tryHttp (mkResponse <$> C.httpLbs req man)- where- --idHttp :: (C.HttpException -> IO a) -> (C.HttpException -> IO a)- --idHttp = id-- tryHttp :: IO a -> IO (Either C.HttpException a)- tryHttp = try------- | Relevant bits of server response, packed into a record--- for those who don't want to deal with http-clients's--- 'Network.HTTP.Client.Response' type.------ See 'mkResponse'.-data Response =- Response {- statusCode :: Int- , message :: L.ByteString- , contentType :: L.ByteString- , responseBody :: L.ByteString- }- deriving Show---- adapt http-client 'Network.HTTP.Client.Response' type into a--- 'Response'-mkResponse :: HResponse L.ByteString -> Response-mkResponse resp =- let code = (T.statusCode . responseStatus) resp- mesg = LBS.fromStrict $ (T.statusMessage . responseStatus) resp- ctype = LBS.fromStrict $ fromJust $ lookup "Content-Type" $- responseHeaders resp- body = C.responseBody resp- in Response code mesg ctype body----- | Construct a @POST@ request for uploading a package.------ @postPkg url conts userAuth@ creates a request which will upload the file conts--- in @conts@ to the URL at @url@, using the user authentication--- @userAuth@.-postPkg- :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth ->- IO Request-postPkg url fileName fileConts userAuth = do- let conts :: IO RequestBody- conts = RequestBodyLBS `liftM`- maybe (LBS.readFile fileName) return fileConts- (Options opt) = defaultOptions userAuth- formBody = formDataBody [partFileRequestBodyM "package" fileName conts]- opt <$> (formBody =<< parseRequest url)---- | Build a @PUT@ request to upload package documentation.------ @putDocs url fileConts userAuth@ creates a request which will upload the file contents--- in @fileConts@ to the URL at @url@, using the user authentication--- @userAuth@.-putDocs :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth -> IO Request-putDocs url fileName fileConts userAuth = do- conts <- maybe (LBS.readFile fileName) return fileConts- -- build up request- let (Options opt) = defaultOptions userAuth- addMore x = x {- method = "PUT"- , requestHeaders = ("Content-Type", "application/x-tar")- : ("Content-Encoding", "gzip")- : requestHeaders x- , requestBody = RequestBodyLBS conts- }- addMore . opt <$> parseRequest url---- | given a filename and contents, produce an http-client 'Part'--- for uploading as a package to a hackage server-mkPart :: FilePath -> L.ByteString -> Part-mkPart fileName fileConts = do- let myConts = return $ RequestBodyLBS fileConts- partFileRequestBodyM "package" fileName myConts----- | Convert a 'RequestBody' to a 'ByteString'.------ For testing purposes. Won't work if your 'RequestBody' is set up to do--- streaming (e.g. using the 'RequestBodyStream' constructor/ 'partFileSource').-bodyToByteString :: RequestBody -> L.ByteString-bodyToByteString b = case b of- RequestBodyLBS lbs -> lbs- RequestBodyBS bs -> Bu.toLazyByteString $ Bu.byteString bs- RequestBodyBuilder _sz builder -> Bu.toLazyByteString builder- _ -> error "bodyToBS not done yet"---
− src-doctest/DocTest.hs
@@ -1,7 +0,0 @@--import System.FilePath.Glob (glob)-import Test.DocTest (doctest)--main :: IO ()-main = glob "lib/**/*.hs" >>= doctest-
− src-hspec-test/Distribution/Hup/Parse/Test.hs
@@ -1,66 +0,0 @@---{- |--Support code for testing Distribution.Hup.Parse---}-module Distribution.Hup.Parse.Test where--import Data.List (intercalate)-import Data.ByteString.Lazy.Char8 (pack)-import Test.QuickCheck--import Distribution.Hup.Parse--arbWord :: Gen String-arbWord = do- len <- choose (1, 10)- vectorOf len $- oneof [choose ('a', 'z')- ,choose ('A', 'Z')]---arbName :: Gen String-arbName = do- len <- choose (1, 4)- intercalate "-" <$> vectorOf len arbWord--arbVersion :: Gen String-arbVersion = do- numComponents <- choose (1,10)- numbers <- vectorOf numComponents $ getNonNegative <$>- (arbitrary :: Gen (NonNegative Int))- return $ intercalate "." $ map show numbers---- Generate an Upload, including an empty file contents.-arbUpload :: Gen Upload-arbUpload = do- name <- arbName- ver <- arbVersion- isPack <- elements [IsPackage, IsDocumentation]- isCand <- elements [NormalPkg, CandidatePkg]- let pk = Package name ver- file = name ++ "-" ++ ver ++- if isPack == IsPackage- then ".tar.gz"- else "-docs.tar.gz"- return $ Upload pk file (Just $ pack "") isPack isCand--prop_parseTgzFilename_roundtripsOK :: Property-prop_parseTgzFilename_roundtripsOK =- forAll arbUpload $ \upl ->- let- parsed :: Either String (IsDocumentation, Package)- parsed = (parseTgzFilename' $ fileToUpload upl )-- in case parsed of- Right (isDoc, Package parsedName parsedVer) ->- isDoc == uploadType upl- && parsedName == packageName ( package upl)- && parsedVer == packageVersion ( package upl)- Left _msg ->- False---
− src-hspec-test/Distribution/Hup/ParseSpec.hs
@@ -1,28 +0,0 @@---module Distribution.Hup.ParseSpec where--import Test.Hspec-import Test.QuickCheck (Gen, Property)-import qualified Distribution.Hup.Parse.Test--arbWord :: Gen String-arbWord = Distribution.Hup.Parse.Test.arbWord--prop_parseTgzFilename_roundtripsOK :: Property-prop_parseTgzFilename_roundtripsOK =- Distribution.Hup.Parse.Test.prop_parseTgzFilename_roundtripsOK----- `main` is here so that this module can be run from GHCi on its own. It is--- not needed for automatic spec discovery.-main :: IO ()-main = hspec spec--spec :: Spec-spec =- describe "parseTgzFilename" $- it "should round-trip back to original name, version, package type"- prop_parseTgzFilename_roundtripsOK--
− src-hspec-test/Distribution/Hup/Upload/MockWebApp.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Distribution.Hup.Upload.MockWebApp- (- webApp- )- where---import Control.Exception (throwIO)-import Control.Monad-import Control.Monad.IO.Class (liftIO, MonadIO)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as LBS -- pack-import Data.Maybe (fromJust)-import Network.HTTP.Types as T (StdMethod(..))-import Network.Wai.Parse as Parse (FileInfo(..), fileName)-import Web.Simple (ok, respond,Controller, ControllerT, routePattern, queryParam, routeMethod,parseForm, request, rawPathInfo,controllerApp, Application)--import Distribution.Hup.Upload-import Distribution.Hup.Parse---- | We send the parsed results back as plain text,--- parseable by 'Text.Read.read'.-webApp :: Application-webApp = controllerApp () $ do- myReq <- request- routeMethod T.POST $ do path <- rawPathInfo <$> request- let isCand = if "/candidates/" `BS.isSuffixOf`path- then CandidatePkg- else NormalPkg- when (path == "/packages/" ||- path == "/packages/candidates/") $ do- (_params, files) <- parseForm- handlePost isCand files- routeMethod T.PUT $ routePattern "/package/:pkgVer/:isCand" $ do- pkgVer <- fromJust <$> queryParam "pkgVer"- let filename = pkgVer :: String- isCand <- fromJust <$> queryParam "isCand"- let isCand' = if ("candidate" :: String) == isCand- then CandidatePkg- else NormalPkg- let remainingBit = if "candidate"== isCand- then "docs"- else ""- routePattern remainingBit $- handlePut isCand' filename- where- handlePost :: IsCandidate -> [(a, FileInfo c)] -> ControllerT s IO b- handlePost isCand files = do- ioAssert (length files == 1)- "posted package should have exactly 1 file"- let filename = BS.unpack $ Parse.fileName $ snd $ head files- parsed :: Either String (IsDocumentation, Package)- parsed = parseTgzFilename' filename- respond $ ok "text/plain" $ LBS.pack $ show (IsPackage, isCand, parsed)-- handlePut :: IsCandidate -> FilePath -> Controller s a- handlePut isCand filename = do- let parsed :: Either String (IsDocumentation, Package)- parsed = parseTgzFilename' (filename ++ "-docs.tar.gz")- respond $ ok "text/plain" $ LBS.pack $- show (IsDocumentation, isCand, parsed)---- duplicated code from Hup.UploadSpec, remove--- or refactor-ioAssert :: MonadIO f => Bool -> String -> f ()-ioAssert pred mesg =- unless pred $- liftIO $ throwIO $ userError mesg---
− src-hspec-test/Distribution/Hup/Upload/Test.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--{- | Support for testing Distribution.Hup.Upload ---}--module Distribution.Hup.Upload.Test where--import qualified Data.ByteString.Lazy.Char8 as LBS -- pack-import qualified Network.HTTP.Client as HTTP.Client-import System.FilePath ( (</>) )-import System.IO.Temp (withSystemTempDirectory)-import Test.QuickCheck-import Test.QuickCheck.Monadic (run, assert, monadicIO)--import Distribution.Hup.Upload -import Distribution.Hup.Parse.Test--type ParsedTgz = Either String (IsDocumentation, Package) --arbAuth :: Gen (Maybe Auth)-arbAuth =- mkAuth <$> arbitrary <*> arbitrary----- | Round-trips an http request to check things seem to be going to the--- right URLs.------ Doesn't check the file/body, just metadata.--{--- httpRoundTripsOK'-- :: (HTTP.Client.Request -> IO Response)-- -> Int -> Property--}-httpRoundTripsOK' sendRequest port = - forAll arbUpload $ \upl ->- forAll arbAuth $ \auth ->- httpRoundTripsOK sendRequest port upl auth--{--httpRoundTripsOK :: (HTTP.Client.Request -> IO Response)- -> Int -> Upload -> Maybe Auth -> Property--}-httpRoundTripsOK sendRequest port upl auth = - monadicIO $ do- response <- run $ emptyFileRequest port upl auth- assert $ statusCode response == 200-- let bod = LBS.unpack $ responseBody response- _unserialized :: (IsDocumentation, IsCandidate, ParsedTgz)- _unserialized@(recdIsDoc1, recdIsCand, parsedTgz) = read bod-- let sentIsCand = isCandidate upl- sentIsDoc = uploadType upl- sentPkg = package upl -- assert (parsedTgz == Right (sentIsDoc, sentPkg) )- assert (sentIsCand == recdIsCand)- assert (sentIsDoc == recdIsDoc1)- where- emptyFileRequest :: Int -> Upload -> Maybe Auth -> IO Response- emptyFileRequest port upl auth = - withSystemTempDirectory "huptest" $ \tmpDir -> do- let newFile = tmpDir </> fileToUpload upl- upl <- return $ upl { fileToUpload = newFile } - writeFile (tmpDir </> fileToUpload upl) ""- let url = "http://localhost:" ++ show port ++ "/"- buildRequest url upl auth >>= sendRequest----- | Round-trips an http request to check things seem to be going to the--- right URLs.------ Doesn't check the file/body, just metadata.-badUrlReturns'- :: (HTTP.Client.Request -> IO Response)- -> Int -> Property-badUrlReturns' sendRequest port = - forAll arbUpload $ \upl ->- forAll arbAuth $ \auth ->- badUrlReturns sendRequest port upl auth------ | Given a bad url, the http library should return a --- non-2XX status code, rather than throwing an exception.--{--badUrlReturns :: (HTTP.Client.Request -> IO Response)- -> Int -> Upload -> Maybe Auth -> Property--}-badUrlReturns sendRequest port upl auth = - monadicIO $ do- response <- run $ badRequest port upl auth- assert $ statusCode response /= 200-- where- badRequest :: Int -> Upload -> Maybe Auth -> IO Response- badRequest port upl auth = - withSystemTempDirectory "huptest" $ \tmpDir -> do- let newFile = tmpDir </> fileToUpload upl- upl <- return $ upl { fileToUpload = newFile } - writeFile (tmpDir </> fileToUpload upl) ""- let url = "http://localhost:" ++ show port ++ "/fubar/"- buildRequest url upl auth >>= sendRequest----
− src-hspec-test/Distribution/Hup/UploadSpec.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Distribution.Hup.UploadSpec where--import Control.Exception (throwIO)-import Control.Monad-import Control.Monad.IO.Class (liftIO, MonadIO)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as LBS -- pack-import Data.Maybe (fromJust)-import Data.Monoid ( (<>) )-import Network.HTTP.Client.MultipartFormData (renderParts,webkitBoundary)-import Network.HTTP.Types as T (statusCode,methodPost)-import Network.Wai.Test (simpleStatus,SResponse- ,simpleBody)-import Test.Hspec-import qualified Test.Hspec.Wai as HWai --(put, request)-import Test.Hspec.Wai.Internal --(WaiSession,runWaiSession)-import Test.QuickCheck --(forAll)-import Test.QuickCheck.Monadic --(assert, run, monadicIO )---import Distribution.Hup.Parse-import Distribution.Hup.Parse.Test-import Distribution.Hup.Upload-import Distribution.Hup.Upload.MockWebApp (webApp)--import qualified Distribution.Hup.WebTest--type ParsedTgz = Either String (IsDocumentation, Package)----- `main` is here so that this module can be run from GHCi on its own. It is--- not needed for automatic spec discovery.-main :: IO ()-main =- hspec spec--spec :: Spec-spec = do- describe "testing with mocked requests" $- describe "mocked requests" $- context "when processed by a mock hackage server" $- it "should go to the right web app path"- httpMetadataRoundtripsOK'- describe "testing with live HTTP requests" $- -- this will be replaced with a stub unless the WEB_TESTS macro- -- is defined.- --- -- 'webApp' is a very simple web application- -- intended to mock some of the behaviour of a- -- hackage server.- Distribution.Hup.WebTest.liveTest webApp---httpMetadataRoundtripsOK' :: Property-httpMetadataRoundtripsOK' =- forAll arbUpload $ \upl -> httpMetadataRoundtripsOK upl--httpMetadataRoundtripsOK :: Upload -> Property-httpMetadataRoundtripsOK upl = monadicIO $ do- upl <- return $ upl { fileConts = Just "" }- testRequest <- run $ buildTestRequest "" upl- testResponse <- run $ sendTestRequest testRequest-- let resStatus = T.statusCode $ simpleStatus testResponse- resBody :: String- resBody = LBS.unpack $ simpleBody testResponse- _unserialized :: (IsDocumentation, IsCandidate, ParsedTgz)- _unserialized@(recdIsDoc1, recdIsCand, parsedTgz) = read resBody-- let sentIsCand = isCandidate upl- sentIsDoc = uploadType upl- sentPkg = package upl-- assert (resStatus == 200)- assert (sentIsCand == recdIsCand)- assert (sentIsDoc == recdIsDoc1)- assert (parsedTgz == Right (sentIsDoc, sentPkg) )---sendTestRequest :: WaiSession SResponse -> IO SResponse-sendTestRequest testReq =- runWaiSession testReq webApp---testPut :: String -> LBS.ByteString -> WaiSession SResponse-testPut url conts =- HWai.put (BS.pack url) conts--testPost- :: String -> FilePath -> LBS.ByteString -> IO (WaiSession SResponse)-testPost url fileName fileConts = do- boundary <- webkitBoundary- let part = mkPart fileName fileConts- headers = [("Content-Type",- "multipart/form-data; boundary=" <> boundary)]- body <- bodyToByteString <$> renderParts boundary [part]- return $ HWai.request T.methodPost (BS.pack url) headers body----- Only call when fileConts has something in it.-buildTestRequest- :: String -> Upload -> IO (WaiSession SResponse)-buildTestRequest serverUrl upl = do- let (Upload _ filePath fileConts uploadType _pkgType ) = upl- url = getUploadUrl serverUrl upl- fileConts <- return (fromJust fileConts)- case uploadType of- IsPackage ->- testPost url filePath fileConts- IsDocumentation ->- return $ testPut url fileConts--ioAssert :: MonadIO f => Bool -> String -> f ()-ioAssert pred mesg =- unless pred $- liftIO $ throwIO $ userError mesg-----
− src-hspec-test/Distribution/Hup/WebTest.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE CPP #-}--module Distribution.Hup.WebTest where---import Distribution.Hup.Upload (sendRequest)-import Distribution.Hup.Upload.Test-import Network.Wai (Application)-import Test.Hspec-import Test.Hspec.Core.QuickCheck (modifyMaxSuccess)--#ifdef WEB_TESTS--import Control.Concurrent (forkIO, ThreadId)-import qualified Network.Socket as Soc (Socket, close)-import Network.Wai.Handler.Warp (Port, defaultSettings- ,runSettingsSocket)---#if MIN_VERSION_warp(3,2,4)-import qualified Network.Wai.Handler.Warp as Warp (openFreePort)--openFreePort :: IO (Port, Soc.Socket)-openFreePort = Warp.openFreePort-#else-import Network.Socket--openFreePort :: IO (Port, Soc.Socket)-openFreePort = do- s <- socket AF_INET Stream defaultProtocol- localhost <- inet_addr "127.0.0.1"- bind s (SockAddrInet aNY_PORT localhost)- listen s 1- port <- socketPort s- return (fromIntegral port, s)-#endif---- Pulls a "Right" value out of an Either value. If the Either value is--- Left, raises an exception with "error".-forceEither :: Show e => Either e a -> a-forceEither (Left x) = error (show x)-forceEither (Right x) = x--startServer :: Application -> IO (Port, Soc.Socket, ThreadId)-startServer webApp = do- (port, sock) <- openFreePort- tid <- forkIO $ runSettingsSocket defaultSettings sock webApp- return (port, sock, tid)--shutdownServer :: (Port, Soc.Socket, ThreadId) -> IO ()-shutdownServer (_port, sock, _tid) =- Soc.close sock--liveTest :: Application -> SpecWith ()-liveTest webApp = do- beforeAll (startServer webApp) $ afterAll shutdownServer $- describe "buildRequest" $ do- context "when its result is fed into sendRequest" $- modifyMaxSuccess (const 50) $- it "should send to the right web app path" $ \(port, _sock, _tid) ->- httpRoundTripsOK' sendRequest' port-- context "when given a bad URL" $- modifyMaxSuccess (const 50) $- it "should not throw an exception" $ \(port, _sock, _tid) ->- badUrlReturns' sendRequest' port--{--sendRequest' :: http-client-0.5.5:Network.HTTP.Client.Types.Request- -> IO Distribution.Hup.Upload.Response--}-sendRequest' req = forceEither <$> sendRequest req---#else--liveTest :: Application -> SpecWith ()-liveTest _ = return ()--#endif---
− src-hspec-test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− src/CmdArgs.hs
@@ -1,209 +0,0 @@--{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}--module CmdArgs where--import Data.Version (showVersion)-import Paths_hup (version)-import System.Console.CmdArgs hiding(cmdArgs)-import System.Environment (getArgs, withArgs)--import qualified DefaultServerUrl-import CmdArgs.PatchHelp (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 PASSWORD environment"- ,"variable instead of on the command line.\n", "\n'hup --help=all'"- ,"will give help for all commands." ]-
− src/CmdArgs/PatchHelp.hs
@@ -1,112 +0,0 @@--{-# LANGUAGE CPP #-}--{- |--Bits of cmdargs-0.10.14.1, included purely to add some extra-info to the output of "--help".---}--module CmdArgs.PatchHelp where---#ifdef PATCH_HELP--import Data.Char (toLower, isDigit)-import System.Console.CmdArgs.Annotate-import System.Console.CmdArgs.Explicit hiding (flagHelpFormat)-import System.Console.CmdArgs.Implicit.Internal.Global hiding(global,extraFlags)-import System.Console.CmdArgs.Implicit.Internal.Local-import System.Console.CmdArgs.Implicit hiding(cmdArgs,cmdArgsMode,cmdArgsCapture)-import System.Console.CmdArgs.Text-import System.Console.CmdArgs.Implicit.Internal.Reform(reform)--tmpXX = 'a'---{---- | Create a help flag triggered by @-?@/@--help@. The user--- may optionally modify help by specifying the format, such as:------ > --help=all - help for all modes--- > --help=html - help in HTML format--- > --help=100 - wrap the text at 100 characters--- > --help=100,one - full text wrapped at 100 characters------ From System.Console.CmdArgs.Explicit.flagHelpFormat--}-flagHelpFormat :: (HelpFormat -> TextFormat -> a -> a) -> Flag a-flagHelpFormat f = (flagOpt "" ["help","?"] upd "" "Display help message. '--help=all' will display help for all commnds. '--help=bash' will output code for bash command-line completion."){flagInfo = FlagOptRare ""}- where- upd s v = case format s of- Left e -> Left e- Right (a,b) -> Right $ f a b v-- format :: String -> Either String (HelpFormat,TextFormat)- format xs = foldl (\acc x -> either Left (f x) acc) (Right def) (sep xs)- where- sep = words . map (\x -> if x `elem` ":," then ' ' else toLower x)- f x (a,b) = case x of- "all" -> Right (HelpFormatAll,b)- "one" -> Right (HelpFormatOne,b)- "def" -> Right (HelpFormatDefault,b)- "html" -> Right (a,HTML)- "text" -> Right (a,defaultWrap)- "bash" -> Right (HelpFormatBash,Wrap 1000000)- "zsh" -> Right (HelpFormatZsh ,Wrap 1000000)- _ | all isDigit x -> Right (a,Wrap $ read x)- _ -> Left "unrecognised help format, expected one of: all one def html text <NUMBER>"--global :: Prog_ -> Mode (CmdArgs Any)-global x = setReform (reform y) $ setHelp y $ setProgOpts x $ collapse $ assignGroups y- where y = assignNames $ extraFlags x---extraFlags :: Prog_ -> Prog_-extraFlags p = p{progModes = map f $ progModes p}- where f m = m{modeFlags_ = modeFlags_ m ++ flags}- grp = if length (progModes p) > 1 then Just commonGroup else Nothing- wrap x = def{flagFlag=x, flagExplicit=True, flagGroup=grp}- flags = changeBuiltin_ (progHelpArg p) (wrap $ flagHelpFormat $ error "flagHelpFormat undefined") ++- changeBuiltin_ (progVersionArg p) (wrap $ flagVersion vers) ++- [wrap $ flagNumericVersion $ \x -> x{cmdArgsVersion = Just $ unlines v}- | Just v <- [progNumericVersionOutput p]] ++- changeBuiltin_ (fst $ progVerbosityArgs p) (wrap loud) ++- changeBuiltin_ (snd $ progVerbosityArgs p) (wrap quiet)- [loud,quiet] = flagsVerbosity verb- vers x = x{cmdArgsVersion = Just $ unlines $ progVersionOutput p}- verb v x = x{cmdArgsVerbosity = Just v}---cmdArgsCapture :: Data a => Capture Ann -> Mode (CmdArgs a)-cmdArgsCapture = remap embed proj . global . local- where embed = fmap fromAny- proj x = (fmap Any x, embed)---- | Take impurely annotated records and turn them in to a 'Mode' value, that can--- make use of the "System.Console.CmdArgs.Explicit" functions (i.e. 'process').------ Annotated records are impure, and will only contain annotations on--- their first use. The result of this function is pure, and can be reused.-cmdArgsMode :: Data a => a -> Mode (CmdArgs a)-cmdArgsMode = cmdArgsCapture . capture---- | Take impurely annotated records and run the corresponding command line.--- Shortcut for @'cmdArgsRun' . 'cmdArgsMode'@.------ To use 'cmdArgs' with custom command line arguments see--- 'System.Environment.withArgs'.-cmdArgs :: Data a => a -> IO a-cmdArgs = cmdArgsRun . cmdArgsMode--#else--import System.Console.CmdArgs.Implicit hiding (cmdArgs)-import qualified System.Console.CmdArgs.Implicit --cmdArgs :: Data a => a -> IO a-cmdArgs = System.Console.CmdArgs.Implicit.cmdArgs --#endif-
− src/DefaultServerUrl.hs
@@ -1,13 +0,0 @@---module DefaultServerUrl where---- | The default hackage server URL.-defaultServerUrl :: String-defaultServerUrl = "https://hackage.haskell.org/"---defaultServerUrl = "http://localhost:8080/"-----
+ src/Distribution/Hup.hs view
@@ -0,0 +1,44 @@++-- {-# OPTIONS_HADDOCK hide, prune #-}++{- |+ Bits and pieces for building and uploading source or documentation .tar files+ for Hackage, intended to make it easy to write your own Haskell+ programs/scripts for managing uploads.++ This is the main entry-point to look at, and more low-level functions are+ available in the other modules.+-}++module Distribution.Hup+ (+ -- * Finding and parsing Cabal files+ findCabal+ , readCabal+ , extractCabal+ -- * Parsing .tgz file names+ , parseTgzFilename+ , parseTgzFilename'+ -- * Building tar files+ , buildTar+ -- * Uploading+ , getUploadUrl+ , mkAuth+ , postPkg+ , putDocs+ , buildRequest+ , sendRequest+ -- * Types+ , IsCandidate(..)+ , IsDocumentation(..)+ , Package(..)+ , Upload(..)+ , Auth(..)+ )+ where+++import Distribution.Hup.BuildTar+import Distribution.Hup.Parse+import Distribution.Hup.Upload+
+ src/Distribution/Hup/BuildTar.hs view
@@ -0,0 +1,26 @@++{- | Build tar files++-}++module Distribution.Hup.BuildTar+ (+ buildTar+ )+ where++import Codec.Archive.Tar as Tar (write, pack)+import qualified Codec.Compression.GZip as GZ+import Data.ByteString.Lazy as BS hiding (pack)+import Prelude hiding (read)+++-- | @buildTar tarFileName baseDir paths@ -+-- create a gz-compressed tar file with name tarFileName,+-- with files in it from baseDir, "paths" being the files & directories+-- to archive, relative to baseDir.+buildTar :: FilePath -> FilePath -> [FilePath] -> IO ()+buildTar tarFileName baseDir paths = + BS.writeFile tarFileName . GZ.compress . write =<< pack baseDir paths ++
+ src/Distribution/Hup/Parse.hs view
@@ -0,0 +1,167 @@++{-|++extract info from cabal files and .tgz names.++-}++module Distribution.Hup.Parse+ (+ module Distribution.Hup.Parse+ , module Distribution.Hup.Types+ )+ where++import Control.Monad.Except (MonadError(..),when)++import Data.Char (isDigit, toLower, isSpace)+import Data.List (dropWhileEnd,isSuffixOf,stripPrefix+ ,intercalate)+import Data.List.Split (splitOn)++import Data.Maybe (listToMaybe)+import Data.String+import System.Directory (getDirectoryContents)+import System.FilePath (splitExtension, splitFileName, takeExtension)++import Distribution.Hup.Types (IsCandidate(..), IsDocumentation(..)+ ,Package(..), Upload(..) )+++-- | strip whitespace from end+--+-- >>> rstrip "abcd \t\n\r"+-- "abcd"+rstrip :: String -> String+rstrip = dropWhileEnd isSpace++-- | strip whitespace from beginning+--+-- >>> lstrip "\t\n\r abcd"+-- "abcd"+lstrip :: String -> String+lstrip = dropWhile isSpace++-- | Replace a subsequence everywhere it occurs. The first argument must+-- not be the empty list.+--+-- from NDM's <https://hackage.haskell.org/package/extra-1.5.1 extra-1.5.1>+--+-- >>> replace "el" "_" "Hello Bella" == "H_lo B_la"+-- True+-- >>> replace "el" "e" "Hello" == "Helo"+-- True+--+-- > \xs ys -> not (null xs) ==> replace xs xs ys == ys+-- > replace "" "e" "Hello" == undefined+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace [] _ _ = error "Extra.replace, first argument cannot be empty"+replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs+replace from to (x:xs) = x : replace from to xs+replace _from _to [] = []++-- | Like 'Data.List.dropWhileEnd', but for 'Data.List.take'.+--+-- (taken from filepath-1.4.1.1)+--+-- >>> takeWhileEnd (< 10) [1, 2, 10, 3, 4, -3]+-- [3,4,-3]+takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd p = reverse . takeWhile p . reverse++-- | like 'Data.List.span', but from the end+--+-- >>> spanEnd (< 3) [4,3,2,1,4,3,2,1]+-- ([4,3,2,1,4,3],[2,1])+-- >>> spanEnd (< 9) [1,2,3]+-- ([],[1,2,3])+-- >>> spanEnd (< 0) [1,2,3]+-- ([1,2,3],[])+spanEnd :: (a -> Bool) -> [a] -> ([a], [a])+spanEnd p xs = (dropWhileEnd p xs, takeWhileEnd p xs)+++-- | like 'Data.List.break', but from the end+--+-- >>> breakEnd (> 3) [4,3,2,1,4,3,2,1]+-- ([4,3,2,1,4],[3,2,1])+-- >>> breakEnd (< 9) [1,2,3]+-- ([1,2,3],[])+-- >>> breakEnd (> 9) [1,2,3]+-- ([],[1,2,3])+breakEnd :: (a -> Bool) -> [a] -> ([a], [a])+breakEnd p = spanEnd (not . p)+++-- | if there's a .cabal file in the current dir, return its file name.+--+-- from NDM's <https://hackage.haskell.org/package/neil-0.10 neil-0.10>+findCabal :: IO (Maybe Prelude.FilePath)+findCabal = do+ x <- getDirectoryContents "."+ return $ listToMaybe $ filter ((==) ".cabal" . takeExtension) x++-- | find & read contents of Cabal file from current dir, if it exists.+-- else returns empty string.+--+-- from NDM's <https://hackage.haskell.org/package/neil-0.10 neil-0.10>+readCabal :: IO String+readCabal = do+ file <- findCabal+ case file of+ Nothing -> return []+ Just file -> readFile file+++-- | @extractCabal fieldName cabalConts@:+-- extract contents of field named `fieldName` from a Cabal file string.+--+-- field name is case-insensitive [folded to lowercase]+--+-- from NDM's <https://hackage.haskell.org/package/neil-0.10 neil-0.10>+extractCabal :: String -> String -> String+extractCabal find = f . words . replace ":" " : "+ where+ f (name:":":val:_) | map toLower find == map toLower name = val+ f (_x:xs) = f xs+ f [] = error "Failed to find the Cabal key " ++ find++-- | Inspect the name of a .tar.gz file to work out the package name+-- and version it's for, and whether it is for documentation or a package.+parseTgzFilename+ :: (IsString s, MonadError s m) =>+ Prelude.FilePath -> m (IsDocumentation, Package)+parseTgzFilename f = do+ let (base, ext) = splitExtension f+ ext `shouldBe` ".gz"+ (base, ext) <- return $ splitExtension base+ ext `shouldBe` ".tar"+ base <- return $ snd $ splitFileName base+ (base, isDocco) <- return $ if "-docs" `isSuffixOf` base+ then let base' = intercalate "-" $+ init $ splitOn "-" base+ in (base', IsDocumentation)+ else (base, IsPackage)+ let (pkg, ver) = spanVersion base+ pkg <- return $ dropWhileEnd (=='-') pkg+ return (isDocco, Package pkg ver)++ where+ ext `shouldBe` expected =+ when (ext /= expected) $+ throwError $ fromString $ unwords ["Expected filename with extension"+ ,"'.tar.gz', but got", f]+ spanVersion = spanEnd (\x -> isDigit x || x == '.')++-- | 'parseTgzFilename'' specialized to 'Data.Either.Either'.+--+-- >>> (parseTgzFilename' "foo-bar-baz-0.1.0.0.2.3.0.1.tar.gz") :: Either String (IsDocumentation, Package)+-- Right (IsPackage,Package {packageName = "foo-bar-baz", packageVersion = "0.1.0.0.2.3.0.1"})+parseTgzFilename'+ :: (IsString s) =>+ Prelude.FilePath -> Either s (IsDocumentation, Package)+parseTgzFilename' = parseTgzFilename++++
+ src/Distribution/Hup/Types.hs view
@@ -0,0 +1,44 @@+++{-| ++types useful package-wide++-}++module Distribution.Hup.Types+ (+ IsCandidate(..)+ , IsDocumentation(..)+ , Package(..)+ , Upload(..)+ )+ where++import qualified Data.ByteString.Lazy as L++-- | whether a package is a normal one or a candidate+data IsCandidate = NormalPkg | CandidatePkg+ deriving (Show, Eq, Read)++-- | are we uploading a package or just docs+data IsDocumentation = IsPackage | IsDocumentation+ deriving (Show, Eq, Read)++-- | name and version of a package+data Package = Package { packageName :: String+ ,packageVersion :: String } + deriving (Show, Eq, Read)++++-- | Bundle together information useful for an upload.+data Upload = + Upload { package :: Package -- ^ package name & version+ ,fileToUpload :: FilePath -- ^ file being uploaded+ ,fileConts :: Maybe L.ByteString -- ^ file conts+ ,uploadType :: IsDocumentation -- ^ docco or package + ,isCandidate :: IsCandidate -- ^ candidate or not+ } deriving (Show, Eq)++
+ src/Distribution/Hup/Upload.hs view
@@ -0,0 +1,257 @@++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE CPP #-}++{-|++Handle uploading to a hackage server, using the @HTTP@ API described+in the+<https://hackage.haskell.org/api Hackage server documentation>.++-}++module Distribution.Hup.Upload+ (+ module Distribution.Hup.Upload+ , module Distribution.Hup.Types+ , Auth(..)+ )+ where++import Control.Monad+import qualified Data.ByteString.Builder as Bu+import Data.List (dropWhileEnd)+import Data.Maybe (fromJust)+import Data.ByteString.Char8 (pack,ByteString )+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.Lazy as L (ByteString)+import Data.Monoid ( (<>) )+import qualified Network.HTTP.Client as C+import Network.HTTP.Client (requestHeaders, Request, RequestBody(..)+ ,method, requestBody, responseHeaders+ ,responseStatus)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import qualified Network.HTTP.Types as T+import Network.HTTP.Client.MultipartFormData+ (formDataBody,partFileRequestBodyM+ ,Part)++import Distribution.Hup.Types+-- for re-export++import Control.Exception+++#if MIN_VERSION_http_client(0,4,30)+parseRequest :: String -> IO Request+parseRequest = C.parseRequest+#else++parseRequest :: String -> IO Request+parseRequest =+ fmap noThrow . C.parseUrl+ where+ noThrow req = req { C.checkStatus = \_ _ _ -> Nothing }+#endif++++-- | Alias for <https://hackage.haskell.org/package/http-client http-client's>+-- 'Network.HTTP.Client.Response' type.+type HResponse = C.Response++-- | Username and password for HTTP basic access authentication.+data Auth = Auth { authUser :: ByteString+ , authPassword :: ByteString }+ deriving (Eq, Show)++-- | Options that can be applied to a Request.+-- (e.g. to add standard headers, etc.)+--+-- Can just use 'defaultOptions'.+newtype Options = Options (Request -> Request)+-- deriving Show++++-- | returns default options to use with+-- a request.+--+-- We try to request plain text where possible;+-- and we allow non-success statuses to still return normally+-- (rather than throwing an exception)+defaultOptions :: Maybe Auth -> Options+defaultOptions mAuth =+ case mAuth of+ Nothing -> Options id+ Just (Auth user pass) -> Options $ modify . C.applyBasicAuth user pass++ where+ modify :: Request -> Request+ modify x = x {+ requestHeaders = ("User-Agent", "haskell hup-0.1.0.0")+ : ("Accept", "text/plain")+ : requestHeaders x+ }++++-- | pack a name and password into an 'Auth' structure+--+-- >>> mkAuth "myname" "mypassword"+-- Just (Auth {authUser = "myname", authPassword = "mypassword"})+mkAuth :: String -> String -> Maybe Auth+mkAuth name password =+ Just $ Auth (pack name) (pack password)++-- | work out what URL to upload a .tgz file to.+-- @getUploadUrl server upload@ returns a URL.+--+-- >>> getUploadUrl "http://localhost:8080/" $ Upload (Package "foo" "0.1.0.0") "./foo-0.1.0.0.tar.gz" Nothing IsDocumentation CandidatePkg+-- "http://localhost:8080/package/foo-0.1.0.0/candidate/docs"+getUploadUrl+ :: String -> Upload -> String+getUploadUrl server upl =+-- TODO:+-- handle Yackage as well?+-- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs+ let+ -- we are permissive, and drop any extra trailing slashes on server.+ serverUrl = dropWhileEnd (=='/') server+ (Upload (Package pkgName pkgVer) _filePath _fileConts uploadType pkgType ) = upl+ in case uploadType of+ IsPackage -> case pkgType of+ NormalPkg -> serverUrl <>"/packages/"+ CandidatePkg -> serverUrl <>"/packages/candidates/"+ IsDocumentation ->+ case pkgType of+ NormalPkg -> serverUrl <> "/package/" <> pkgName+ <> "-" <> pkgVer <> "/docs"+ CandidatePkg -> serverUrl <> "/package/" <> pkgName+ <> "-" <> pkgVer+ <> "/candidate/docs"++-- | @buildRequest serverUrl upl userAuth@ - create an HTTP request+-- for uploading some package (details+-- packed into @upl@) to the server at @serverUrl@, using+-- the credentials in @userAuth@.+--+-- e.g. usage:+--+-- > let p = Package "foo" "0.1.0.0"+-- > let u = Upload p "./foo-0.1.0.0.tar.gz" Nothing IsDocumentation CandidatePkg+-- > req <- buildRequest "http://localhost:8080/" u (mkAuth "tmp" "tmp")+-- > sendRequest req+buildRequest :: String -> Upload -> Maybe Auth -> IO Request+buildRequest serverUrl upl userAuth =+-- TODO:+-- handle Yackage as well?+-- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs+ let (Upload _ filePath fileConts uploadType _pkgType ) = upl+ in case uploadType of+ IsPackage -> do+ let url = getUploadUrl serverUrl upl+ postPkg url filePath fileConts userAuth+ IsDocumentation -> do+ let url = getUploadUrl serverUrl upl+ putDocs url filePath fileConts userAuth++-- | Send an HTTP request and get the response (or an exception)+sendRequest :: Request -> IO (Either C.HttpException Response)+sendRequest req =+ do+ man <- C.newManager tlsManagerSettings+ tryHttp (mkResponse <$> C.httpLbs req man)+ where+ --idHttp :: (C.HttpException -> IO a) -> (C.HttpException -> IO a)+ --idHttp = id++ tryHttp :: IO a -> IO (Either C.HttpException a)+ tryHttp = try+++++-- | Relevant bits of server response, packed into a record+-- for those who don't want to deal with http-clients's+-- 'Network.HTTP.Client.Response' type.+--+-- See 'mkResponse'.+data Response =+ Response {+ statusCode :: Int+ , message :: L.ByteString+ , contentType :: L.ByteString+ , responseBody :: L.ByteString+ }+ deriving Show++-- adapt http-client 'Network.HTTP.Client.Response' type into a+-- 'Response'+mkResponse :: HResponse L.ByteString -> Response+mkResponse resp =+ let code = (T.statusCode . responseStatus) resp+ mesg = LBS.fromStrict $ (T.statusMessage . responseStatus) resp+ ctype = LBS.fromStrict $ fromJust $ lookup "Content-Type" $+ responseHeaders resp+ body = C.responseBody resp+ in Response code mesg ctype body+++-- | Construct a @POST@ request for uploading a package.+--+-- @postPkg url conts userAuth@ creates a request which will upload the file conts+-- in @conts@ to the URL at @url@, using the user authentication+-- @userAuth@.+postPkg+ :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth ->+ IO Request+postPkg url fileName fileConts userAuth = do+ let conts :: IO RequestBody+ conts = RequestBodyLBS `liftM`+ maybe (LBS.readFile fileName) return fileConts+ (Options opt) = defaultOptions userAuth+ formBody = formDataBody [partFileRequestBodyM "package" fileName conts]+ opt <$> (formBody =<< parseRequest url)++-- | Build a @PUT@ request to upload package documentation.+--+-- @putDocs url fileConts userAuth@ creates a request which will upload the file contents+-- in @fileConts@ to the URL at @url@, using the user authentication+-- @userAuth@.+putDocs :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth -> IO Request+putDocs url fileName fileConts userAuth = do+ conts <- maybe (LBS.readFile fileName) return fileConts+ -- build up request+ let (Options opt) = defaultOptions userAuth+ addMore x = x {+ method = "PUT"+ , requestHeaders = ("Content-Type", "application/x-tar")+ : ("Content-Encoding", "gzip")+ : requestHeaders x+ , requestBody = RequestBodyLBS conts+ }+ addMore . opt <$> parseRequest url++-- | given a filename and contents, produce an http-client 'Part'+-- for uploading as a package to a hackage server+mkPart :: FilePath -> L.ByteString -> Part+mkPart fileName fileConts = do+ let myConts = return $ RequestBodyLBS fileConts+ partFileRequestBodyM "package" fileName myConts+++-- | Convert a 'RequestBody' to a 'ByteString'.+--+-- For testing purposes. Won't work if your 'RequestBody' is set up to do+-- streaming (e.g. using the 'RequestBodyStream' constructor/ 'partFileSource').+bodyToByteString :: RequestBody -> L.ByteString+bodyToByteString b = case b of+ RequestBodyLBS lbs -> lbs+ RequestBodyBS bs -> Bu.toLazyByteString $ Bu.byteString bs+ RequestBodyBuilder _sz builder -> Bu.toLazyByteString builder+ _ -> error "bodyToBS not done yet"+++
− src/DocBuilding.hs
@@ -1,207 +0,0 @@--{-# 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 CmdArgs (HupCommands(..))-import Data.Text ( Text )-import qualified Data.Text as T-import Data.Monoid ( (<>) )-import Shelly.Lifted-import Data.Char (isSpace)-import Prelude hiding (FilePath)-import Control.Monad.IO.Class ( MonadIO(..) )-import qualified Stack-import Distribution.Hup ( Package(..), buildTar )-import Control.Exception-import Shelly ( ReThrownException )---- | 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_sh---- | Build a documentation .tgz file.------ A Haskellified version of--- phadej's script at------ <https://github.com/phadej/binary-orphans/blob/master/hackage-docs.sh>,------ which is a stack-enabled version of ekmett's script at------ <https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh>.------ @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-
− src/Main.hs
@@ -1,258 +0,0 @@--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--module 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.Either (either)-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 "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---- exit early-done :: Monad m => ExceptT Done m a-done = throwE Done--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 ()---
− src/SanityCheck.hs
@@ -1,64 +0,0 @@--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module SanityCheck 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)-import CmdArgs.PatchHelp (cmdArgs)---- 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"---------
− src/Stack.hs
@@ -1,107 +0,0 @@--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExtendedDefaultRules #-}--{- |--Abstract over some of stack's functionality.---}--module Stack-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-
− src/Types.hs
@@ -1,25 +0,0 @@--module Types 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)- ---
− src/Upload.hs
@@ -1,92 +0,0 @@--{-# 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 (all, 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 = ["<style>", "<header>", "<title>", "<meta>"]- bodyTag :: String- bodyTag = "<body>"-- parsedBod = parseTags bod- notHeader t = all (t ~/=) headerTags - notHeaderBits = toString $ tail $ takeWhileEnd notHeader parsedBod- possBodyBits = toString $ dropWhile (~/= bodyTag) parsedBod-- probBod = maximumBy (comparing length) [notHeaderBits, possBodyBits]-- in collapseWhitespace probBod----
+ stack-lts-14.yaml view
@@ -0,0 +1,10 @@+resolver: lts-14.27++packages:+- .++extra-deps:+- shelly-1.7.2@sha256:80fb7b2e1372d3931c9a7fecae491780d748a6b293de6aa34faad0c861800004,5168++#- simple-0.11.3@sha256:86e0aa9c0ac370c6c7d00ce3dac45c84682a5c3f4e16927187c68ac88bfa55f1,3186+#- simple-templates-0.9.0.0@sha256:0dbddbde2eb27127e6bd0bc151b5a0cd87e7030e4de764827744ac0cbaa1b7ca,1744
stack-lts-3.yaml view
@@ -1,26 +1,9 @@-resolver: lts-3.7+resolver: lts-3.22 packages:-- '.'-# only needed for special patched-# cmdargs with extra help info-#- location:-# git: https://github.com/phlummox/cmdargs-# commit: 39e08514ad470c48c82cb42ef3987455c81727de-# extra-dep: true+- . extra-deps:-# not sure why I'm using this version of shelly --# must've wanted some feature not found in lts-3-# version-- shelly-1.6.8.1-# "simple" and "simple-templates" are only in stackage from lts 4.2-- simple-0.11.1-- simple-templates-0.8.0.1+- shelly-1.7.2@sha256:80fb7b2e1372d3931c9a7fecae491780d748a6b293de6aa34faad0c861800004 -# to enable test code:-# flags:-# hup: #{}-# PatchHelpMessage: true-# EnableWebTests: true
− stack-lts-7.yaml
@@ -1,8 +0,0 @@-resolver: lts-7.24--packages:-- '.'--extra-deps:-- http-client-0.5.5-- http-client-tls-0.3.3
+ test-doctest/DocTest.hs view
@@ -0,0 +1,7 @@++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doctest+
+ test-hspec/Distribution/Hup/Parse/Test.hs view
@@ -0,0 +1,72 @@+++{- |++Support code for testing Distribution.Hup.Parse++-}+module Distribution.Hup.Parse.Test + (+ arbWord+ , arbUpload+ , prop_parseTgzFilename_roundtripsOK+ )+ where++import Data.List (intercalate)+import Data.ByteString.Lazy.Char8 (pack)+import Test.QuickCheck++import Distribution.Hup.Parse++arbWord :: Gen String+arbWord = do+ len <- choose (1, 10)+ vectorOf len $+ oneof [choose ('a', 'z')+ ,choose ('A', 'Z')]+++arbName :: Gen String+arbName = do+ len <- choose (1, 4)+ intercalate "-" <$> vectorOf len arbWord++arbVersion :: Gen String+arbVersion = do+ numComponents <- choose (1,10)+ numbers <- vectorOf numComponents $ getNonNegative <$>+ (arbitrary :: Gen (NonNegative Int))+ return $ intercalate "." $ map show numbers++-- Generate an Upload, including an empty file contents.+arbUpload :: Gen Upload+arbUpload = do+ name <- arbName+ ver <- arbVersion+ isPack <- elements [IsPackage, IsDocumentation]+ isCand <- elements [NormalPkg, CandidatePkg]+ let pk = Package name ver+ file = name ++ "-" ++ ver +++ if isPack == IsPackage+ then ".tar.gz"+ else "-docs.tar.gz"+ return $ Upload pk file (Just $ pack "") isPack isCand++prop_parseTgzFilename_roundtripsOK :: Property+prop_parseTgzFilename_roundtripsOK =+ forAll arbUpload $ \upl ->+ let+ parsed :: Either String (IsDocumentation, Package)+ parsed = (parseTgzFilename' $ fileToUpload upl )++ in case parsed of+ Right (isDoc, Package parsedName parsedVer) ->+ isDoc == uploadType upl+ && parsedName == packageName ( package upl)+ && parsedVer == packageVersion ( package upl)+ Left _msg ->+ False+++
+ test-hspec/Distribution/Hup/ParseSpec.hs view
@@ -0,0 +1,33 @@+++module Distribution.Hup.ParseSpec+ (+ main+ , spec+ )+ where++import Test.Hspec+import Test.QuickCheck (Gen, Property)+import qualified Distribution.Hup.Parse.Test++arbWord :: Gen String+arbWord = Distribution.Hup.Parse.Test.arbWord++prop_parseTgzFilename_roundtripsOK :: Property+prop_parseTgzFilename_roundtripsOK =+ Distribution.Hup.Parse.Test.prop_parseTgzFilename_roundtripsOK+++-- `main` is here so that this module can be run from GHCi on its own. It is+-- not needed for automatic spec discovery.+main :: IO ()+main = hspec spec++spec :: Spec+spec =+ describe "parseTgzFilename" $+ it "should round-trip back to original name, version, package type"+ prop_parseTgzFilename_roundtripsOK++
+ test-hspec/Distribution/Hup/Upload/MockWebApp.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module Distribution.Hup.Upload.MockWebApp+ (+ webApp+ )+ where++import qualified Data.ByteString.Char8 as BS+import qualified Data.Text.Lazy as TL+import Network.Wai (Application )+import Network.Wai.Parse as Parse (FileInfo(..), fileName)+import Web.Scotty hiding (request)++import Distribution.Hup.Upload+import Distribution.Hup.Parse++webApp :: IO Application+webApp =+ scottyApp $ do+ post "/packages/" $+ files >>= handlePost NormalPkg+ post "/packages/candidates/" $+ files >>= handlePost CandidatePkg+ put "/package/:pkgVer/docs" $ do+ pkgVer <- param "pkgVer"+ handlePut NormalPkg pkgVer+ put "/package/:pkgVer/candidate/docs" $ do+ pkgVer <- param "pkgVer"+ handlePut CandidatePkg pkgVer+ where+ handlePost+ :: IsCandidate -> [File] -> ActionM ()+ handlePost isCand files =+ case files of+ [(_fname, body)] -> do+ let+ filename = BS.unpack $ Parse.fileName body++ parsed :: Either String (IsDocumentation, Package)+ parsed = parseTgzFilename' filename+ text $ TL.pack $ show (IsPackage, isCand, parsed)+ _ -> raise "posted package should have exactly 1 file"++ handlePut :: IsCandidate -> FilePath -> ActionM ()+ handlePut isCand filename = do+ let parsed :: Either String (IsDocumentation, Package)+ parsed = parseTgzFilename' (filename ++ "-docs.tar.gz")+ text $ TL.pack $+ show (IsDocumentation, isCand, parsed)+++
+ test-hspec/Distribution/Hup/Upload/Test.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++{- | Support for testing Distribution.Hup.Upload ++-}++module Distribution.Hup.Upload.Test + (+ httpRoundTripsOK'+ , badUrlReturns'+ )+ where++import qualified Data.ByteString.Lazy.Char8 as LBS -- pack+import qualified Network.HTTP.Client as HTTP.Client+import System.FilePath ( (</>) )+import System.IO.Temp (withSystemTempDirectory)+import Test.QuickCheck+import Test.QuickCheck.Monadic (run, assert, monadicIO)++import Distribution.Hup.Upload +import Distribution.Hup.Parse.Test++type ParsedTgz = Either String (IsDocumentation, Package) ++arbAuth :: Gen (Maybe Auth)+arbAuth =+ mkAuth <$> arbitrary <*> arbitrary+++-- | Round-trips an http request to check things seem to be going to the+-- right URLs.+--+-- Doesn't check the file/body, just metadata.+++httpRoundTripsOK' :: (HTTP.Client.Request -> IO Response) -> Int -> Property+httpRoundTripsOK' sendRequest port = + forAll arbUpload $ \upl ->+ forAll arbAuth $ \auth ->+ httpRoundTripsOK sendRequest port upl auth+++httpRoundTripsOK ::+ (HTTP.Client.Request -> IO Response)+ -> Int -> Upload -> Maybe Auth -> Property+httpRoundTripsOK sendRequest port upl auth = + monadicIO $ do+ response <- run $ emptyFileRequest port upl auth+ assert $ statusCode response == 200++ let bod = LBS.unpack $ responseBody response+ _unserialized :: (IsDocumentation, IsCandidate, ParsedTgz)+ _unserialized@(recdIsDoc1, recdIsCand, parsedTgz) = read bod++ let sentIsCand = isCandidate upl+ sentIsDoc = uploadType upl+ sentPkg = package upl ++ assert (parsedTgz == Right (sentIsDoc, sentPkg) )+ assert (sentIsCand == recdIsCand)+ assert (sentIsDoc == recdIsDoc1)+ where+ emptyFileRequest :: Int -> Upload -> Maybe Auth -> IO Response+ emptyFileRequest port upl auth = + withSystemTempDirectory "huptest" $ \tmpDir -> do+ let newFile = tmpDir </> fileToUpload upl+ upl <- return $ upl { fileToUpload = newFile } + writeFile (tmpDir </> fileToUpload upl) ""+ let url = "http://localhost:" ++ show port ++ "/"+ buildRequest url upl auth >>= sendRequest+++-- | Round-trips an http request to check things seem to be going to the+-- right URLs.+--+-- Doesn't check the file/body, just metadata.+badUrlReturns'+ :: (HTTP.Client.Request -> IO Response)+ -> Int -> Property+badUrlReturns' sendRequest port = + forAll arbUpload $ \upl ->+ forAll arbAuth $ \auth ->+ badUrlReturns sendRequest port upl auth++++-- | Given a bad url, the http library should return a +-- non-2XX status code, rather than throwing an exception.++badUrlReturns ::+ (HTTP.Client.Request -> IO Response)+ -> Int -> Upload -> Maybe Auth -> Property+badUrlReturns sendRequest port upl auth = + monadicIO $ do+ response <- run $ badRequest port upl auth+ assert $ statusCode response /= 200++ where+ badRequest :: Int -> Upload -> Maybe Auth -> IO Response+ badRequest port upl auth = + withSystemTempDirectory "huptest" $ \tmpDir -> do+ let newFile = tmpDir </> fileToUpload upl+ upl <- return $ upl { fileToUpload = newFile } + writeFile (tmpDir </> fileToUpload upl) ""+ let url = "http://localhost:" ++ show port ++ "/fubar/"+ buildRequest url upl auth >>= sendRequest++++
+ test-hspec/Distribution/Hup/UploadSpec.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}++module Distribution.Hup.UploadSpec + (+ main+ , spec+ )+ where++import Control.Monad.IO.Class (liftIO)++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS -- pack+import Data.Maybe (fromJust)+import Data.Monoid ( (<>) )++import Network.HTTP.Client.MultipartFormData (renderParts,webkitBoundary)+import Network.HTTP.Types as T (statusCode,methodPost)+import Network.Wai.Test (simpleStatus,SResponse+ ,simpleBody, runSession)++import Test.Hspec+import Test.Hspec.Wai.Internal (WaiSession,runWaiSession,+ getApp)+import Test.QuickCheck+import Test.QuickCheck.Monadic++import Distribution.Hup.Parse.Test ( arbUpload )+import Distribution.Hup.Upload (mkPart, bodyToByteString,+ getUploadUrl, Package(..),+ IsDocumentation(..),+ Upload(..), IsCandidate(..)+ )++import Distribution.Hup.Upload.MockWebApp (webApp)++import qualified Distribution.Hup.WebTest++import Network.Wai+import qualified Network.Wai.Test as Wai+import Network.HTTP.Types as HT++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++type ParsedTgz = Either String (IsDocumentation, Package)+++-- `main` is here so that this module can be run from GHCi on its own. It is+-- not needed for automatic spec discovery.+main :: IO ()+main =+ hspec spec++spec :: Spec+spec = do+ describe "testing with mocked requests" $+ describe "mocked requests" $+ context "when processed by a mock hackage server" $+ it "should go to the right web app path" $+ monadicIO $ do+ webApp' <- run webApp+ return $ httpMetadataRoundtripsOK' webApp'+ describe "testing with live HTTP requests" $+ -- this will be replaced with a stub unless the WEB_TESTS macro+ -- is defined.+ --+ -- 'webApp' is a very simple web application+ -- intended to mock some of the behaviour of a+ -- hackage server.+ Distribution.Hup.WebTest.liveTest webApp++httpMetadataRoundtripsOK' :: Application -> Property+httpMetadataRoundtripsOK' webApp =+ forAll arbUpload $ \upl -> httpMetadataRoundtripsOK webApp upl++httpMetadataRoundtripsOK+ :: Application -> Upload -> Expectation+httpMetadataRoundtripsOK webApp upl = do+ upl <- return $ upl { fileConts = Just "" }+ testRequest <- buildTestRequest "" upl+ testResponse <- sendTestRequest webApp testRequest++ let sentIsCand = isCandidate upl+ sentIsDoc = uploadType upl+ sentPkg = package upl++ let resStatus = T.statusCode $ simpleStatus testResponse+ resBody :: String+ resBody = LBS.unpack $ simpleBody testResponse+ _unserialized :: (IsDocumentation, IsCandidate, ParsedTgz)+ _unserialized@(recdIsDoc1, recdIsCand, parsedTgz) = read resBody++ resStatus `shouldBe` 200+ sentIsCand `shouldBe` recdIsCand+ sentIsDoc `shouldBe` recdIsDoc1+ parsedTgz `shouldBe` Right (sentIsDoc, sentPkg)+++++sendTestRequest ::+ Application -> (Request, LBS.ByteString) -> IO SResponse+sendTestRequest webApp req = do+ runWaiSession (sendRequestImproved req) webApp++++testPut ::+ String -> LBS.ByteString -> (Request, LBS.ByteString)+testPut url conts =+ mkPut (BS.pack url) conts++testPost ::+ String+ -> FilePath -> LBS.ByteString -> IO (Request, LBS.ByteString)+testPost url fileName fileConts = do+ boundary <- webkitBoundary+ let part = mkPart fileName fileConts+ headers = [("Content-Type",+ "multipart/form-data; boundary=" <> boundary)]+ body <- bodyToByteString <$> renderParts boundary [part]+ return $ mkRequest T.methodPost (BS.pack url) headers body+++-- Only call when fileConts has something in it.+buildTestRequest ::+ String -> Upload -> IO (Request, LBS.ByteString)+buildTestRequest serverUrl upl = do+ let (Upload _ filePath fileConts uploadType _pkgType ) = upl+ url = getUploadUrl serverUrl upl+ fileConts <- return (fromJust fileConts)+ case uploadType of+ IsPackage ->+ testPost url filePath fileConts+ IsDocumentation ->+ return $ testPut url fileConts++-- expose more of hspec wai's 'request' internals++mkRequest ::+ Method -> BS.ByteString -> RequestHeaders -> LBS.ByteString -> (Request, LBS.ByteString)+mkRequest method path headers body =+ let req = defaultRequest {requestMethod = method, requestHeaders = headers}+ in (Wai.setPath req path, body)++mkPut ::+ BS.ByteString -> LBS.ByteString -> (Request, LBS.ByteString)+mkPut path body = mkRequest methodPut path [] body++sendRequestImproved :: (Request, LBS.ByteString) -> WaiSession SResponse+sendRequestImproved (req, body) = getApp >>= liftIO . runSession (Wai.srequest $ Wai.SRequest req body)+++
+ test-hspec/Distribution/Hup/WebTest.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE CPP #-}++module Distribution.Hup.WebTest + (+ liveTest+ )+ where+++import Network.Wai (Application)+import Test.Hspec+import Test.Hspec.Core.QuickCheck (modifyMaxSuccess)++import Distribution.Hup.Upload (sendRequest)+import qualified Distribution.Hup.Upload as U+import Distribution.Hup.Upload.Test++#ifdef WEB_TESTS++import Control.Concurrent (forkIO, ThreadId)+import qualified Network.Socket as Soc (Socket, close)+import Network.HTTP.Client+import Network.Wai.Handler.Warp (Port, defaultSettings+ ,runSettingsSocket)++#if MIN_VERSION_warp(3,2,4)+import qualified Network.Wai.Handler.Warp as Warp (openFreePort)++openFreePort :: IO (Port, Soc.Socket)+openFreePort = Warp.openFreePort+#else+import Network.Socket++openFreePort :: IO (Port, Soc.Socket)+openFreePort = do+ s <- socket AF_INET Stream defaultProtocol+ localhost <- inet_addr "127.0.0.1"+ bind s (SockAddrInet aNY_PORT localhost)+ listen s 1+ port <- socketPort s+ return (fromIntegral port, s)+#endif++{-# ANN module "HLint: ignore Redundant do" #-}++-- Pulls a "Right" value out of an Either value. If the Either value is+-- Left, raises an exception with "error".+forceEither :: Show e => Either e a -> a+forceEither (Left x) = error (show x)+forceEither (Right x) = x++startServer :: Application -> IO (Port, Soc.Socket, ThreadId)+startServer webApp = do+ (port, sock) <- openFreePort+ tid <- forkIO $ runSettingsSocket defaultSettings sock webApp+ return (port, sock, tid)++startServer' :: IO Application -> IO (Port, Soc.Socket, ThreadId)+startServer' webApp = do+ webApp' <- webApp+ (port, sock) <- openFreePort+ tid <- forkIO $ runSettingsSocket defaultSettings sock webApp'+ return (port, sock, tid)++++shutdownServer :: (Port, Soc.Socket, ThreadId) -> IO ()+shutdownServer (_port, sock, _tid) =+ Soc.close sock++--- ?? what exactly is this testing???+liveTest :: IO Application -> SpecWith ()+liveTest webApp = do+ beforeAll (startServer' webApp) $ afterAll shutdownServer $+ describe "buildRequest" $ do+ context "when its result is fed into sendRequest" $+ modifyMaxSuccess (const 50) $+ it "should send to the right web app path" $ \(port, _sock, _tid) ->+ httpRoundTripsOK' sendRequest' port++ context "when given a bad URL" $+ modifyMaxSuccess (const 50) $+ it "should not throw an exception" $ \(port, _sock, _tid) ->+ badUrlReturns' sendRequest' port++sendRequest' :: Request -> IO U.Response+sendRequest' req = forceEither <$> sendRequest req+++#else++liveTest :: Application -> SpecWith ()+liveTest _ = return ()++#endif+++
+ test-hspec/Spec.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+#if __GLASGOW_HASKELL__ >= 801+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+#endif