hup 0.3.0.0 → 0.3.0.2
raw patch · 17 files changed
+523/−503 lines, 17 filesdep +simple-templatesdep ~hspec-wai
Dependencies added: simple-templates
Dependency ranges changed: hspec-wai
Files
- ChangeLog.md +38/−13
- README.md +0/−152
- hup.cabal +139/−38
- lib/Distribution/Hup/Upload.hs +40/−40
- src-hspec-test/Distribution/Hup/Parse/Test.hs +15/−13
- src-hspec-test/Distribution/Hup/ParseSpec.hs +7/−4
- src-hspec-test/Distribution/Hup/Upload/MockWebApp.hs +73/−0
- src-hspec-test/Distribution/Hup/Upload/Test.hs +16/−4
- src-hspec-test/Distribution/Hup/UploadSpec.hs +33/−83
- src-hspec-test/Distribution/Hup/WebTest.hs +15/−13
- src/CmdArgs.hs +41/−42
- src/DocBuilding.hs +31/−31
- src/Main.hs +37/−38
- stack-lts-11.yaml +4/−0
- stack-lts-3.yaml +26/−0
- stack-lts-7.yaml +8/−0
- stack.yaml +0/−32
ChangeLog.md view
@@ -1,19 +1,44 @@-## 0.2.0.0+# Changelog for Hup -* Bug fixes-* Allow an Upload to store contents of file to be uploaded.-* Support older versions of directory and http-client-* Allow extra args to be passed to cabal when configuring or when- running haddock.-* Added hspec and docstring tests-* Now running travis CI on a range of platforms and ghc versions.+## 0.3.0.2 +- Library API: no changes.+- Executable behaviour: no change.+- Changes to code and cabal file:+ - Tightened bounds on dependencies, to avoid known+ incompatible versions of dependencies.+ - Internal tidying of unused imports, trailing whitespace,+ missing sigs etc.+ - Enabled extra ghc warning flags during build.+ - Shifted "stack.yaml" out of top directory - poor form :/+ - Added some extra compilation flags (e.g.+ for tests that are unlikely to run without "stack",+ like doctests).++## 0.3.0.1++- Library API: no changes.+- Executable behaviour: no change.+- Some changes to README and Travis config file, and+ thus to the deployed "releases" binary, though.+ ## 0.3.0.0 -* Bug fixes-* Updated documentation, added a "quick usage" section and troubleshooting-* `hup` now checks whether `cabal` is in the package snapshot binaries+- Bug fixes+- Updated documentation, added a "quick usage" section and troubleshooting+- `hup` now checks whether `cabal` is in the package snapshot binaries directory, and installs it if not.-* Added `packbuild` and `packboth` commands.-* Added a program test to .travis.yml+- Added `packbuild` and `packboth` commands.+- Added a program test to .travis.yml++## 0.2.0.0++- Bug fixes+- Allow an Upload to store contents of file to be uploaded.+- Support older versions of directory and http-client+- Allow extra args to be passed to cabal when configuring or when+ running haddock.+- Added hspec and docstring tests+- Now running travis CI on a range of platforms and ghc versions.+
− README.md
@@ -1,152 +0,0 @@-# hup [](https://hackage.haskell.org/package/hup) [](https://travis-ci.org/phlummox/hup) --Small program for building and uploading packages and documentation-built with `stack` to a hackage server; a Haskellified version of-[phadej's script](https://github.com/phadej/binary-orphans/blob/master/hackage-docs.sh),-which is a stack-enabled version of [ekmett's script](https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh).--In addition to `stack`, it 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--Install in the standard Stack way with `stack install hup`.--## 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 `PASSWORD` environment variable instead- of on the command line.- - 'hup --help=all' will give help for all commands.--* Commands:-- packup Upload FILE as a 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. '--help=all' will display help- for all commnds. '--help=bash' will output code for- bash command-line completion.- -V --version Print version information- --numeric-version Print just the version number---* `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 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 will 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 --## 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--- Not yet tested on MS Windows or MacOS--
hup.cabal view
@@ -1,38 +1,70 @@ name: hup-version: 0.3.0.0+version: 0.3.0.2 synopsis: Upload packages or documentation to a hackage server-description: +description: Upload packages or documentation to a hackage server .- See README for details.+ See the README for 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, others where indicated-category: Distribution, Web, Documentation +copyright: phlummox 2016-2020, others where indicated+category: Distribution, Web, Documentation build-type: Simple-tested-with: GHC == 8.0.1, GHC == 7.10.3 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2 cabal-version: >=1.10-extra-source-files: README.md, stack.yaml, ChangeLog.md +extra-source-files:+ ChangeLog.md+ , stack-lts-3.yaml+ , stack-lts-7.yaml+ , stack-lts-11.yaml++source-repository head+ type: git+ location: https://github.com/phlummox/hup+ 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+ Manual: True +Flag ExtraGhcWarnings+ Description: Enable extra ghc warnings+ Default: True+ Manual: True++-- This enables (or disables) tests that rely on+-- stack at runtime. (viz, tests using doctest.)+-- You can enable these tests from stack using+-- `--flag hup:BuildStackBasedTests`+Flag BuildStackBasedTests+ Description: Enable tests requiring stack+ Manual: True+ Default: False++ library hs-source-dirs: lib- exposed-modules: + exposed-modules: Distribution.Hup , Distribution.Hup.BuildTar , Distribution.Hup.Parse , Distribution.Hup.Types , Distribution.Hup.Upload- build-depends: + build-depends: base >= 4.7 && < 5 , bytestring , directory@@ -45,21 +77,32 @@ , tar , zlib default-language: Haskell2010---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- Manual: True+ if flag(ExtraGhcWarnings)+ if impl(ghc >= 8.0.1)+ -- -new-style warn options, plus+ -- can use a few new warnings+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ -Wno-name-shadowing+ -Wno-orphans+ -Wno-type-defaults+ -fwarn-tabs+ else+ ghc-options: -Wall+ -fno-warn-name-shadowing+ -fwarn-incomplete-record-updates+ -fwarn-incomplete-uni-patterns+ -fno-warn-type-defaults+ -fwarn-tabs executable hup hs-source-dirs: src main-is: Main.hs- other-modules: + other-modules: CmdArgs , CmdArgs.PatchHelp , DefaultServerUrl@@ -72,22 +115,45 @@ if flag(PatchHelpMessage) other-modules: CmdArgs.PatchHelp cpp-options: -DPATCH_HELP- build-depends: cmdargs == 0.10.14.1 - else - build-depends: cmdargs + build-depends: cmdargs == 0.10.14.1+ else+ build-depends: cmdargs default-language: Haskell2010- build-depends: - base + build-depends:+ base , bytestring- , directory + , directory , mtl , shelly >= 1.6.6 , tagsoup- -- , temporary >= 1.2.1 , text , transformers , hup+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ if flag(ExtraGhcWarnings)+ if impl(ghc >= 8.0.1)+ -- -new-style warn options, plus+ -- can use a few new warnings+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ -Wno-name-shadowing+ -Wno-orphans+ -Wno-type-defaults+ -fwarn-tabs+ else+ ghc-options: -Wall+ -fno-warn-name-shadowing+ -fwarn-incomplete-record-updates+ -fwarn-incomplete-uni-patterns+ -fno-warn-type-defaults+ -fwarn-tabs + test-suite hup-spec type: exitcode-stdio-1.0 hs-source-dirs: src-hspec-test@@ -96,19 +162,50 @@ base , bytestring , filepath- , hspec-wai+ , hspec-wai < 0.10 , http-client , http-types , hup , hspec , hspec-core , QuickCheck- , simple + , simple , temporary , transformers , wai , wai-extra- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ 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++ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ if flag(ExtraGhcWarnings)+ if impl(ghc >= 8.0.1)+ -- -new-style warn options, plus+ -- can use a few new warnings+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ -Wno-name-shadowing+ -Wno-orphans+ -Wno-type-defaults+ -fwarn-tabs+ else+ ghc-options: -Wall+ -fno-warn-name-shadowing+ -fwarn-incomplete-record-updates+ -fwarn-incomplete-uni-patterns+ -fno-warn-type-defaults+ -fwarn-tabs default-language: Haskell2010 other-modules: Distribution.Hup.WebTest@@ -116,6 +213,7 @@ , Distribution.Hup.Parse.Test , Distribution.Hup.UploadSpec , Distribution.Hup.Upload.Test+ , Distribution.Hup.Upload.MockWebApp if flag(EnableWebTests) build-depends: network@@ -128,21 +226,24 @@ , warp cpp-options: -DWEB_TESTS -+-- **+-- - Only runs using stack, so is disabled+-- by default+-- - Doesn't seem to run w/ lts-3 ... possibly+-- a bug in doctest, who knows test-suite hup-doctest type: exitcode-stdio-1.0 hs-source-dirs: src-doctest main-is: DocTest.hs- build-depends: base- , hup- , doctest- , Glob+ if !(flag(BuildStackBasedTests))+ buildable: False+ else+ build-depends: base+ , hup+ , doctest+ , Glob ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 --source-repository head- type: git- location: https://github.com/phlummox/hup
lib/Distribution/Hup/Upload.hs view
@@ -3,16 +3,16 @@ {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE CPP #-} -{-| +{-| Handle uploading to a hackage server, using the @HTTP@ API described-in the +in the <https://hackage.haskell.org/api Hackage server documentation>. -} module Distribution.Hup.Upload (- module Distribution.Hup.Upload + module Distribution.Hup.Upload , module Distribution.Hup.Types , Auth(..) )@@ -23,7 +23,7 @@ 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.Char8 as LBS import qualified Data.ByteString.Lazy as L (ByteString) import Data.Monoid ( (<>) ) import qualified Network.HTTP.Client as C@@ -31,24 +31,24 @@ ,method, requestBody, responseHeaders ,responseStatus) import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified Network.HTTP.Types as T -import Network.HTTP.Client.MultipartFormData +import qualified Network.HTTP.Types as T+import Network.HTTP.Client.MultipartFormData (formDataBody,partFileRequestBodyM ,Part) -import Distribution.Hup.Types +import Distribution.Hup.Types -- for re-export import Control.Exception #if MIN_VERSION_http_client(0,4,30)---parseRequest :: MonadThrow m => String -> m Request+parseRequest :: String -> IO Request parseRequest = C.parseRequest #else ---parseRequest :: MonadThrow m => String -> m Request-parseRequest = +parseRequest :: String -> IO Request+parseRequest = fmap noThrow . C.parseUrl where noThrow req = req { C.checkStatus = \_ _ _ -> Nothing }@@ -69,19 +69,19 @@ -- (e.g. to add standard headers, etc.) -- -- Can just use 'defaultOptions'.-data Options = Options (Request -> Request)+newtype Options = Options (Request -> Request) -- deriving Show -- | returns default options to use with -- a request.--- --- We try to request plain text where possible; +--+-- 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 = +defaultOptions mAuth = case mAuth of Nothing -> Options id Just (Auth user pass) -> Options $ modify . C.applyBasicAuth user pass@@ -99,36 +99,36 @@ -- | pack a name and password into an 'Auth' structure -- -- >>> mkAuth "myname" "mypassword"--- Just (Auth {authUser = "myname", authPassword = "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. +-- | 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 = +getUploadUrl server upl = -- TODO: -- handle Yackage as well?--- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs - let +-- 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 + serverUrl = dropWhileEnd (=='/') server (Upload (Package pkgName pkgVer) _filePath _fileConts uploadType pkgType ) = upl in case uploadType of IsPackage -> case pkgType of- NormalPkg -> serverUrl <>"/packages/" + NormalPkg -> serverUrl <>"/packages/" CandidatePkg -> serverUrl <>"/packages/candidates/" IsDocumentation -> case pkgType of NormalPkg -> serverUrl <> "/package/" <> pkgName <> "-" <> pkgVer <> "/docs"- CandidatePkg -> serverUrl <> "/package/" <> pkgName - <> "-" <> pkgVer + CandidatePkg -> serverUrl <> "/package/" <> pkgName+ <> "-" <> pkgVer <> "/candidate/docs" -- | @buildRequest serverUrl upl userAuth@ - create an HTTP request@@ -146,7 +146,7 @@ buildRequest serverUrl upl userAuth = -- TODO: -- handle Yackage as well?--- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs +-- https://github.com/snoyberg/yackage/blob/master/yackage-upload.hs let (Upload _ filePath fileConts uploadType _pkgType ) = upl in case uploadType of IsPackage -> do@@ -157,42 +157,42 @@ 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 = +sendRequest :: Request -> IO (Either C.HttpException Response)+sendRequest req = do man <- C.newManager tlsManagerSettings- tryHttp (mkResponse <$> C.httpLbs req man) + tryHttp (mkResponse <$> C.httpLbs req man) where- --idHttp :: (C.HttpException -> IO a) -> (C.HttpException -> IO a) + --idHttp :: (C.HttpException -> IO a) -> (C.HttpException -> IO a) --idHttp = id - tryHttp :: IO a -> IO (Either C.HttpException a) + 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 +-- for those who don't want to deal with http-clients's -- 'Network.HTTP.Client.Response' type. -- -- See 'mkResponse'.-data Response = +data Response = Response { statusCode :: Int , message :: L.ByteString , contentType :: L.ByteString- , responseBody :: L.ByteString + , responseBody :: L.ByteString } deriving Show --- adapt http-client 'Network.HTTP.Client.Response' type into a +-- adapt http-client 'Network.HTTP.Client.Response' type into a -- 'Response' mkResponse :: HResponse L.ByteString -> Response-mkResponse resp = +mkResponse resp = let code = (T.statusCode . responseStatus) resp mesg = LBS.fromStrict $ (T.statusMessage . responseStatus) resp- ctype = LBS.fromStrict $ fromJust $ lookup "Content-Type" $ + ctype = LBS.fromStrict $ fromJust $ lookup "Content-Type" $ responseHeaders resp body = C.responseBody resp in Response code mesg ctype body@@ -204,11 +204,11 @@ -- in @conts@ to the URL at @url@, using the user authentication -- @userAuth@. postPkg- :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth -> + :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth -> IO Request postPkg url fileName fileConts userAuth = do let conts :: IO RequestBody- conts = RequestBodyLBS `liftM` + conts = RequestBodyLBS `liftM` maybe (LBS.readFile fileName) return fileConts (Options opt) = defaultOptions userAuth formBody = formDataBody [partFileRequestBodyM "package" fileName conts]@@ -231,7 +231,7 @@ : requestHeaders x , requestBody = RequestBodyLBS conts }- (addMore . opt) <$> parseRequest url+ addMore . opt <$> parseRequest url -- | given a filename and contents, produce an http-client 'Part' -- for uploading as a package to a hackage server@@ -242,8 +242,8 @@ -- | Convert a 'RequestBody' to a 'ByteString'.--- --- For testing purposes. Won't work if your 'RequestBody' is set up to do +--+-- 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
src-hspec-test/Distribution/Hup/Parse/Test.hs view
@@ -2,7 +2,7 @@ {- | -Support code for testing Distribution.Hup.Parse +Support code for testing Distribution.Hup.Parse -} module Distribution.Hup.Parse.Test where@@ -13,7 +13,7 @@ import Distribution.Hup.Parse -+arbWord :: Gen String arbWord = do len <- choose (1, 10) vectorOf len $@@ -26,11 +26,12 @@ len <- choose (1, 4) intercalate "-" <$> vectorOf len arbWord +arbVersion :: Gen String arbVersion = do numComponents <- choose (1,10)- numbers <- vectorOf numComponents $ getNonNegative <$> + numbers <- vectorOf numComponents $ getNonNegative <$> (arbitrary :: Gen (NonNegative Int))- return $ intercalate "." $ map show numbers + return $ intercalate "." $ map show numbers -- Generate an Upload, including an empty file contents. arbUpload :: Gen Upload@@ -40,24 +41,25 @@ isPack <- elements [IsPackage, IsDocumentation] isCand <- elements [NormalPkg, CandidatePkg] let pk = Package name ver- file = 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 = - forAll arbUpload $ \upl -> - let - parsed :: Either String (IsDocumentation, Package) - parsed = (parseTgzFilename' $ fileToUpload upl ) +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 + Right (isDoc, Package parsedName parsedVer) ->+ isDoc == uploadType upl && parsedName == packageName ( package upl) && parsedVer == packageVersion ( package upl)- Left msg -> + Left _msg -> False
src-hspec-test/Distribution/Hup/ParseSpec.hs view
@@ -3,10 +3,13 @@ module Distribution.Hup.ParseSpec where import Test.Hspec+import Test.QuickCheck (Gen, Property) import qualified Distribution.Hup.Parse.Test -arbWord = Distribution.Hup.Parse.Test.arbWord +arbWord :: Gen String+arbWord = Distribution.Hup.Parse.Test.arbWord +prop_parseTgzFilename_roundtripsOK :: Property prop_parseTgzFilename_roundtripsOK = Distribution.Hup.Parse.Test.prop_parseTgzFilename_roundtripsOK @@ -17,9 +20,9 @@ main = hspec spec spec :: Spec-spec = - describe "parseTgzFilename" $ - it "should round-trip back to original name, version, package type" +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 view
@@ -0,0 +1,73 @@+{-# 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 view
@@ -19,6 +19,7 @@ type ParsedTgz = Either String (IsDocumentation, Package) +arbAuth :: Gen (Maybe Auth) arbAuth = mkAuth <$> arbitrary <*> arbitrary @@ -27,15 +28,21 @@ -- right URLs. -- -- Doesn't check the file/body, just metadata.-httpRoundTripsOK'- :: (HTTP.Client.Request -> IO Response)- -> Int -> Property++{-+- 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@@ -79,6 +86,11 @@ -- | 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
src-hspec-test/Distribution/Hup/UploadSpec.hs view
@@ -2,20 +2,15 @@ module Distribution.Hup.UploadSpec where --- import Control.Exception (throwIO) import Control.Monad-import Control.Monad.IO.Class (liftIO)+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- ,StdMethod(..)) -import Network.Wai.Parse as Parse (FileInfo(..), fileName)+import Network.HTTP.Types as T (statusCode,methodPost) import Network.Wai.Test (simpleStatus,SResponse ,simpleBody) import Test.Hspec@@ -23,45 +18,49 @@ import Test.Hspec.Wai.Internal --(WaiSession,runWaiSession) import Test.QuickCheck --(forAll) import Test.QuickCheck.Monadic --(assert, run, monadicIO )-import Web.Simple --(Application,controllerApp, ControllerT,Controller,ok,parseForm, queryParam, rawPathInfo, request, respond, routeMethod, routePattern) -import Distribution.Hup.Upload -import Distribution.Hup.Parse +import Distribution.Hup.Parse import Distribution.Hup.Parse.Test+import Distribution.Hup.Upload+import Distribution.Hup.Upload.MockWebApp (webApp) -import qualified Distribution.Hup.WebTest +import qualified Distribution.Hup.WebTest -type ParsedTgz = Either String (IsDocumentation, Package) +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 +main =+ hspec spec spec :: Spec spec = do- describe "testing with mocked requests" $ + 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" $ + 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' = - forAll arbUpload $ \upl -> httpMetadataRoundtripsOK upl -+httpMetadataRoundtripsOK' :: Property+httpMetadataRoundtripsOK' =+ forAll arbUpload $ \upl -> httpMetadataRoundtripsOK upl -httpMetadataRoundtripsOK upl = monadicIO $ do +httpMetadataRoundtripsOK :: Upload -> Property+httpMetadataRoundtripsOK upl = monadicIO $ do upl <- return $ upl { fileConts = Just "" }- testRequest <- run $ buildTestRequest "" upl + testRequest <- run $ buildTestRequest "" upl testResponse <- run $ sendTestRequest testRequest let resStatus = T.statusCode $ simpleStatus testResponse@@ -81,26 +80,20 @@ sendTestRequest :: WaiSession SResponse -> IO SResponse-sendTestRequest testReq = +sendTestRequest testReq = runWaiSession testReq webApp ---showInd x =--- indent 4 (show x) ------indent n = --- let wspace = replicate n ' ' --- in unlines . (map (wspace ++)) . lines testPut :: String -> LBS.ByteString -> WaiSession SResponse-testPut url conts = +testPut url conts = HWai.put (BS.pack url) conts testPost :: String -> FilePath -> LBS.ByteString -> IO (WaiSession SResponse) testPost url fileName fileConts = do- boundary <- webkitBoundary + boundary <- webkitBoundary let part = mkPart fileName fileConts- headers = [("Content-Type", + headers = [("Content-Type", "multipart/form-data; boundary=" <> boundary)] body <- bodyToByteString <$> renderParts boundary [part] return $ HWai.request T.methodPost (BS.pack url) headers body@@ -114,58 +107,15 @@ url = getUploadUrl serverUrl upl fileConts <- return (fromJust fileConts) case uploadType of- IsPackage -> + IsPackage -> testPost url filePath fileConts- IsDocumentation -> - return $ testPut url fileConts -+ IsDocumentation ->+ return $ testPut url fileConts -ioAssert pred mesg = +ioAssert :: MonadIO f => Bool -> String -> f ()+ioAssert pred mesg = unless pred $ liftIO $ throwIO $ userError mesg---- | 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)-
src-hspec-test/Distribution/Hup/WebTest.hs view
@@ -1,16 +1,13 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Distribution.Hup.WebTest where -import Distribution.Hup.Upload (sendRequest) +import Distribution.Hup.Upload (sendRequest) import Distribution.Hup.Upload.Test-import Distribution.Hup.Parse import Network.Wai (Application) import Test.Hspec import Test.Hspec.Core.QuickCheck (modifyMaxSuccess)-import Test.QuickCheck #ifdef WEB_TESTS @@ -23,12 +20,13 @@ #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 +openFreePort = do s <- socket AF_INET Stream defaultProtocol localhost <- inet_addr "127.0.0.1" bind s (SockAddrInet aNY_PORT localhost)@@ -45,28 +43,32 @@ startServer :: Application -> IO (Port, Soc.Socket, ThreadId) startServer webApp = do- (port, sock) <- openFreePort + (port, sock) <- openFreePort tid <- forkIO $ runSettingsSocket defaultSettings sock webApp- return (port, sock, tid) + return (port, sock, tid) shutdownServer :: (Port, Soc.Socket, ThreadId) -> IO ()-shutdownServer (_port, sock, _tid) = +shutdownServer (_port, sock, _tid) = Soc.close sock liveTest :: Application -> SpecWith () liveTest webApp = do- beforeAll (startServer webApp) $ afterAll shutdownServer $ + beforeAll (startServer webApp) $ afterAll shutdownServer $ describe "buildRequest" $ do- context "when its result is fed into sendRequest" $ + context "when its result is fed into sendRequest" $ modifyMaxSuccess (const 50) $- it "should send to the right web app path" $ \(port, sock, tid) -> + it "should send to the right web app path" $ \(port, _sock, _tid) -> httpRoundTripsOK' sendRequest' port - context "when given a bad URL" $ + context "when given a bad URL" $ modifyMaxSuccess (const 50) $- it "should not throw an exception" $ \(port, sock, tid) -> + 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
src/CmdArgs.hs view
@@ -2,13 +2,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-cse #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-}-{-# LANGUAGE ViewPatterns #-} module CmdArgs where import Data.Version (showVersion) import Paths_hup (version)-import System.Console.CmdArgs hiding(cmdArgs) +import System.Console.CmdArgs hiding(cmdArgs) import System.Environment (getArgs, withArgs) import qualified DefaultServerUrl@@ -42,56 +41,56 @@ defaultServer :: String-defaultServer = DefaultServerUrl.defaultServerUrl +defaultServer = DefaultServerUrl.defaultServerUrl -- | Actions the program can perform-data HupCommands = +data HupCommands = Docbuild { verbose :: Bool , executables :: Bool , tests :: Bool , internal :: Bool- ,haddockArgs :: String + ,haddockArgs :: String ,quick :: Bool }- | Docboth { verbose :: Bool + | Docboth { verbose :: Bool , executables :: Bool , tests :: Bool , internal :: Bool- , haddockArgs :: String - , quick :: Bool - , server :: String + , haddockArgs :: String+ , quick :: Bool+ , server :: String , candidate :: Bool- , user :: Maybe String + , user :: Maybe String , password :: Maybe String } | Packbuild { verbose :: Bool }- - | Packup { verbose :: Bool ++ | Packup { verbose :: Bool , server :: String , candidate :: Bool- , user :: Maybe String + , user :: Maybe String , password :: Maybe String , file :: String } - | Packboth { verbose :: Bool + | Packboth { verbose :: Bool , server :: String , candidate :: Bool- , user :: Maybe String + , user :: Maybe String , password :: Maybe String } - | Docup { verbose :: Bool - , server :: String + | Docup { verbose :: Bool+ , server :: String , candidate :: Bool- , user :: Maybe String + , 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 +isUpload x = Just x --- Helpers for specifying metavariables etc. for +-- Helpers for specifying metavariables etc. for -- arguments. {-# INLINE serverArg #-}@@ -108,11 +107,11 @@ {-# INLINE fileArg #-} fileArg :: Data val => val -> val-fileArg x = x &= typ "FILE" +fileArg x = x &= typ "FILE" {-# INLINE verbArgs #-} verbArgs :: Data val => val -> val-verbArgs x = x &= help "be verbose" +verbArgs x = x &= help "be verbose" -- commands that can be run @@ -125,13 +124,13 @@ packup :: HupCommands-packup = +packup = Packup { verbose = verbArgs def- ,server = serverArg defaultServer - ,candidate = def - ,file = fileArg def &= argPos 0 - ,user = userArg Nothing + ,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)."])@@ -140,15 +139,15 @@ packboth = Packboth { verbose = verbArgs def- ,server = serverArg defaultServer - ,candidate = def - ,user = userArg Nothing + ,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 = Docbuild { verbose = verbArgs def ,executables = def &= help "Run haddock for Executables targets"@@ -158,7 +157,7 @@ ,haddockArgs = def &= help "extra args to pass to haddock" &= explicit &= name "haddock-arguments"- &= typ "ARGS" + &= typ "ARGS" ,quick = def &= help (unwords ["quick build - don't build" ,"docco for dependencies (links may" ,"be broken)"])@@ -167,15 +166,15 @@ docup :: HupCommands docup =- Docup - { server = serverArg defaultServer - ,file = fileArg def &= argPos 0 + Docup+ { server = serverArg defaultServer+ ,file = fileArg def &= argPos 0 } &= help "Upload FILE as documentation." docboth :: HupCommands-docboth = - Docboth +docboth =+ Docboth {} &= help "Build and upload documentation for a package." @@ -186,21 +185,21 @@ -- If the user did not specify any arguments, pretend "--help" was given (if null args then withArgs ["--help"] else id) proc - where + where proc :: IO HupCommands proc = cmdArgs $ -- commands that can be run, i.e. "modes" modes [packbuild- ,packup + ,packup ,packboth- ,docbuild -- &= groupname "A" + ,docbuild -- &= groupname "A" ,docup -- &= groupname "B"- ,docboth ] -- &= groupname "C"] + ,docboth ] -- &= groupname "C"] &= help progHelp &= program "hup" &= summary ("hup v" ++ showVersion version) &= helpArg [explicit, name "h", name "help"] - progHelp = unwords + 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"
src/DocBuilding.hs view
@@ -11,12 +11,12 @@ -} -module DocBuilding +module DocBuilding ( -- * given a 'HupCommand', what arguments are needed verbosityArgs- , haddockExtraArgs - , cabalExtraArgs + , haddockExtraArgs+ , cabalExtraArgs -- * actions , buildDependencyDocs , cabalConfigure@@ -29,7 +29,7 @@ ) where -import CmdArgs (HupCommands(..), isUpload, processArgs)+import CmdArgs (HupCommands(..)) import Data.Text ( Text ) import qualified Data.Text as T import Data.Monoid ( (<>) )@@ -37,14 +37,14 @@ import Data.Char (isSpace) import Prelude hiding (FilePath) import Control.Monad.IO.Class ( MonadIO(..) )-import qualified Stack +import qualified Stack import Distribution.Hup ( Package(..), buildTar ) import Control.Exception-import Shelly ( ReThrownException ) +import Shelly ( ReThrownException ) -- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m, -- 'MonadShControl' m@-type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m) +type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m) rstrip :: Text -> Text rstrip = T.dropWhileEnd isSpace@@ -53,13 +53,13 @@ -- | 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 [] +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 +haddockExtraArgs hc =+ let args = haddockArgs hc in (if null args then [] else ["--haddock-options=" <>T.pack(haddockArgs hc)])@@ -75,7 +75,7 @@ -- | run haddock with "--only-dependencies" buildDependencyDocs :: MonadSh m => m ()-buildDependencyDocs = do+buildDependencyDocs = run_ "stack" ["haddock", "--only-dependencies"] -- | given a "base" dir, return the "dist" subdir@@ -91,33 +91,33 @@ :: MonadShellish m => FilePath -> [Text] -> [Text] -> m () cabalConfigure baseDir cabalExtraArgs verbosityArgs = do- let tt = toTextIgnore + 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 + 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 tt = toTextIgnore+ canHyperlink <- Stack.haddockCanHyperlinkSrc let hyperlinkArgs = if canHyperlink then ["--haddock-option=--hyperlinked-source"] else []- run_ "cabal" $ ["haddock", "--builddir=" <> tt (buildDir baseDir), + run_ "cabal" $ ["haddock", "--builddir=" <> tt (buildDir baseDir), "--html-location=/package/$pkg-$version/docs",- "--contents-location=/package/$pkg-$version"] + "--contents-location=/package/$pkg-$version"] ++ hyperlinkArgs ++ verbosityArgs- ++ haddockExtraArgs + ++ haddockExtraArgs -- | Tar up the html produced by haddock into a "-docs.tar.gz" file.@@ -129,9 +129,9 @@ 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" + 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" ]@@ -139,7 +139,7 @@ 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 +-- 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@@ -162,9 +162,9 @@ -- -- Sample usage: ----- > :set -XOverloadedStrings +-- > :set -XOverloadedStrings -- > let p = Package "foo" "0.1"--- > shelly $ verbosely $ buildDocs "." p +-- > 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@@ -177,7 +177,7 @@ buildDocs :: MonadShellish m => HupCommands -> FilePath -> Package -> m FilePath-buildDocs hc tmpDir pkg = +buildDocs hc tmpDir pkg = do unless (quick hc) $ do echo "building dependency docs"@@ -191,7 +191,7 @@ echo "building tar file" doBuildTar tmpDir pkg where- -- copy the html files from where haddock puts them to + -- 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@@ -199,7 +199,7 @@ ver = T.pack ver_ srcDir = baseDir </> "dist" </> "doc" </> "html" </> pkg tgtDir = baseDir </> (pkg <> "-" <> ver <> "-docs")- echo $ "copying from " <> (toTextIgnore srcDir) <> " to " <> (toTextIgnore tgtDir)+ 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 ]
src/Main.hs view
@@ -12,7 +12,6 @@ module Main where import Prelude hiding (FilePath)-import qualified Prelude import Control.Monad import Control.Monad.IO.Class ( MonadIO(..) )@@ -30,16 +29,16 @@ --import qualified System.IO.Temp as Tmp import Distribution.Hup ( Package(..),IsDocumentation(..)- ,IsCandidate(..),Auth(..),Upload(..)- ,mkAuth - ,readCabal, extractCabal- ,parseTgzFilename' + , IsCandidate(..),Auth(..),Upload(..)+ , mkAuth+ , readCabal, extractCabal+ , parseTgzFilename' , getUploadUrl) import CmdArgs (HupCommands(..), isUpload, processArgs- ,isBuild, isBoth, isDoc)-import DocBuilding (buildDocs) + , isBuild, isBoth, isDoc)+import DocBuilding (buildDocs) import SanityCheck (sanity)-import qualified Stack +import qualified Stack import Upload (doUpload) @@ -59,12 +58,12 @@ -- -- Sample usage: ----- > import Distribution.Hup.Upload --- > :set -XOverloadedStrings +-- > 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") +-- > 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.@@ -106,7 +105,7 @@ 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) + return $ Upload p tgzFile Nothing IsPackage (isCand hc) -- | if we have a username, then we need to get@@ -114,7 +113,7 @@ getAuth :: MonadSh m => HupCommands -> m (Maybe Auth) getAuth hc = runMaybeT $ do hc <- MaybeT $ return $ isUpload hc- u <- MaybeT $ return $ user hc + u <- MaybeT $ return $ user hc case password hc of Just p -> MaybeT $ return $ mkAuth u p Nothing -> do x <- get_env "PASSWORD"@@ -127,10 +126,10 @@ data Done = Done deriving (Show) -type MonadDone m a = ExceptT Done m a +type MonadDone m a = ExceptT Done m a runEarlyReturn :: Monad m => MonadDone m () -> m ()-runEarlyReturn f = +runEarlyReturn f = either (const ()) id <$> runExceptT f -- exit early@@ -138,10 +137,10 @@ done = throwE Done isCand :: HupCommands -> IsCandidate-isCand hc = +isCand hc = if candidate hc then CandidatePkg- else NormalPkg + else NormalPkg -- | Look at a FILE command-line arg of something we've been asked to -- upload, & try uploading it.@@ -155,22 +154,22 @@ -- -- todo: give nice error messages, rather than throwing exceptions -- in some cases?-uploadTgz :: +uploadTgz :: (MonadSh m, MonadIO m, MonadReader HupCommands m) => IsDocumentation -> Text -> MonadDone m ()-uploadTgz expectedType desc = do +uploadTgz expectedType desc = do hc <- ask- let fileName = file hc + let fileName = file hc fileName'' = T.pack fileName- candType = isCand hc + candType = isCand hc serverUrl = server hc verb = verbose hc (upType, Package pkg ver) <- let parsed = parseTgzFilename' fileName- in either (lift . terror) return parsed + 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 + 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@@ -179,9 +178,9 @@ (if verb then T.pack msg else "")- case serverResponse of + case serverResponse of Left err -> do lift $ echo $ "Error from server:\n" <> T.pack err- throwE Done + throwE Done Right msg -> lift $ echo $ displayedMesg msg @@ -194,7 +193,7 @@ -- > let d = Docbuild { verbose = True } -- > shelly $ verbosely $ runReaderT $ mainSh d mainSh :: MonadHup m => m ()-mainSh = do +mainSh = do hc <- ask --tmpBase <- liftIO $ Tmp.getCanonicalTemporaryDirectory --tmpDir <- fromText . T.pack <$> liftIO (Tmp.createTempDirectory tmpBase "hup")@@ -203,13 +202,13 @@ -- * 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 - !res <- runEarlyReturn $ do+ withTmpDir $ \tmpDir -> do+ !_ <- runEarlyReturn $ do cabalConts <- liftIO readCabal let packageName = extractCabal "name" cabalConts- packageVer = extractCabal "version" cabalConts + packageVer = extractCabal "version" cabalConts case hc of- Packup {} -> do uploadTgz IsPackage "package" + Packup {} -> do uploadTgz IsPackage "package" throwE Done Docup {} -> do uploadTgz IsDocumentation "documentation" throwE Done@@ -218,13 +217,13 @@ _ -> 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 + buildRes <- case hc of (isDoc -> True) -> lift $ stackBuildDocs tmpDir p _ -> lift $ stackSourceDist p- + let tgzFile = fromText $ T.pack $ fileToUpload buildRes - case hc of + case hc of Packbuild {} -> throwE Done -- build only Docbuild {} -> lift (cp tgzFile ".") >> throwE Done -- no need to upload,@@ -234,9 +233,9 @@ let url = getUploadUrl (server hc) uploadable lift $ echo $ "uploading to " <> T.pack url response <- liftIO $ doUpload (server hc) uploadable auth- case response of + case response of Left err -> do lift $ echo $ "Error from server:\n'" <> T.pack err- throwE Done + throwE Done Right msg -> lift $ do echo "Uploaded successfully" echo $ "mesg was: " <> T.pack msg return ()@@ -250,9 +249,9 @@ let verbosify = if verbose hupCommand then verbosely else id- shelly $ do- verbosify $ do - runReaderT mainSh hupCommand + shelly $+ verbosify $+ runReaderT mainSh hupCommand return ()
+ stack-lts-11.yaml view
@@ -0,0 +1,4 @@+resolver: lts-11.22++packages:+- .
+ stack-lts-3.yaml view
@@ -0,0 +1,26 @@+resolver: lts-3.7++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++# to enable test code:+# flags:+# hup: #{}+# PatchHelpMessage: true+# EnableWebTests: true+
+ stack-lts-7.yaml view
@@ -0,0 +1,8 @@+resolver: lts-7.24++packages:+- '.'++extra-deps:+- http-client-0.5.5+- http-client-tls-0.3.3
− stack.yaml
@@ -1,32 +0,0 @@-resolver: lts-7.24-#resolver: lts-3.7--packages:-- '.'-#- location:-# git: https://github.com/phlummox/cmdargs-# commit: 39e08514ad470c48c82cb42ef3987455c81727de-# extra-dep: true--extra-deps:- -## for lts-3.7-#- shelly-1.6.8.1-#- simple-0.11.1-#- simple-templates-0.8.0.1--# for lts-7.14-##- http-client-0.4.31.2-- http-client-0.5.5-- http-client-tls-0.3.3--# flags: {}--# to enable test code:-flags:- hup: #{}-# PatchHelpMessage: true- EnableWebTests: true--extra-package-dbs: []-