hup (empty) → 0.2.0.0
raw patch · 24 files changed
+2058/−0 lines, 24 filesdep +Globdep +QuickCheckdep +basesetup-changed
Dependencies added: Glob, QuickCheck, base, bytestring, cmdargs, directory, doctest, filepath, hspec, hspec-wai, http-client, http-client-tls, http-types, hup, mtl, network, shelly, simple, split, tagsoup, tar, temporary, text, transformers, vector, wai, wai-extra, warp, zlib
Files
- LICENSE +26/−0
- README.md +120/−0
- Setup.hs +2/−0
- hup.cabal +145/−0
- lib/Distribution/Hup.hs +47/−0
- lib/Distribution/Hup/BuildTar.hs +23/−0
- lib/Distribution/Hup/Parse.hs +169/−0
- lib/Distribution/Hup/Types.hs +38/−0
- lib/Distribution/Hup/Upload.hs +252/−0
- src/CmdArgs.hs +140/−0
- src/CmdArgs/PatchHelp.hs +112/−0
- src/DefaultServerUrl.hs +13/−0
- src/Main.hs +316/−0
- src/SanityCheck.hs +57/−0
- src/Types.hs +25/−0
- src/Upload.hs +89/−0
- stack.yaml +32/−0
- test/Distribution/Hup/Parse/Test.hs +65/−0
- test/Distribution/Hup/ParseSpec.hs +33/−0
- test/Distribution/Hup/Upload/Test.hs +100/−0
- test/Distribution/Hup/UploadSpec.hs +176/−0
- test/Distribution/Hup/WebTest.hs +70/−0
- test/DocTest.hs +7/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright phlummox (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,120 @@+# hup [](https://hackage.haskell.org/package/hup) [](https://travis-ci.org/phlummox/hup) [](https://ci.appveyor.com/project/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`, requires that `cabal` and `haddock` are on your path.+(If you're using stack, they're easily installed with, e.g. `stack install+cabal-install`.)++## Installation++Install in the standard Haskell way: `cabal install hup`, or `stack+install hup`.++## 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 ++## 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++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hup.cabal view
@@ -0,0 +1,145 @@+name: hup+version: 0.2.0.0+synopsis: Upload packages or documentation to a hackage server+description: + Upload packages or documentation to a hackage server+ .+ See README for details.+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 +build-type: Simple+tested-with: GHC == 8.0.1, GHC == 7.10.3 +cabal-version: >=1.10+extra-source-files: README.md, stack.yaml ++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+++library+ hs-source-dirs: lib+ exposed-modules: + Distribution.Hup+ , Distribution.Hup.BuildTar+ , Distribution.Hup.Parse+ , Distribution.Hup.Types+ , Distribution.Hup.Upload+ build-depends: + base >= 4.7 && < 5+ , bytestring+ , directory+ , filepath+ , http-client+ , http-client-tls+ , http-types+ , mtl+ , split+ , 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+++executable hup+ hs-source-dirs: src+ main-is: Main.hs+ other-modules: + CmdArgs+ , CmdArgs.PatchHelp+ , DefaultServerUrl+ , Paths_hup+ , SanityCheck+ , Types+ , Upload+ 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 + , mtl+ , shelly >= 1.6.5+ -- shelly - higher possibly needed?+ , tagsoup+ , text+ , transformers+ , hup++test-suite hup-spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ base+ , bytestring+ , filepath+ , hspec-wai+ , http-client+ , http-types+ , hup+ , hspec+ , QuickCheck+ , simple + , temporary+ , transformers+ , wai+ , wai-extra+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ other-modules:+ Distribution.Hup.WebTest+ , Distribution.Hup.ParseSpec+ , Distribution.Hup.Parse.Test+ , Distribution.Hup.UploadSpec+ , Distribution.Hup.Upload.Test+ if flag(EnableWebTests)+ build-depends:+ network+ , vector+ -- ridiculous. With cabal 1.24 and ghc 8.0.1, (a) installing dependencies+ -- fails if 'vector' isn't added here (despite it not being a direct+ -- dependency) and (b) the build takes much longer than with, e.g.+ -- ghc 7.10.3.+ -- TODO: track down the problem sometime.+ , warp+ cpp-options: -DWEB_TESTS+++test-suite hup-doctest+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: DocTest.hs+ 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.hs view
@@ -0,0 +1,47 @@++-- {-# 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.Types+import Distribution.Hup.Upload+
+ lib/Distribution/Hup/BuildTar.hs view
@@ -0,0 +1,23 @@++{- | 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 view
@@ -0,0 +1,169 @@++{-| ++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.ByteString.Lazy.Char8 (pack)+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 view
@@ -0,0 +1,38 @@+++{-| ++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 view
@@ -0,0 +1,252 @@++{-# 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,unpack,putStrLn,ByteString(..) )+import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Lazy as L (ByteString)+import qualified Data.ByteString as BS +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++++#if MIN_VERSION_http_client(0,4,30)+--parseRequest :: MonadThrow m => String -> m Request+parseRequest = C.parseRequest+#else++--parseRequest :: MonadThrow m => String -> m 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'.+data 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.+-- +-- May throw an exception on network errors etc., but not on+-- a non-2XX response (e.g. a 404).+sendRequest+ :: Request -> IO Response+sendRequest req = do+ man <- C.newManager tlsManagerSettings+ mkResponse <$> C.httpLbs req man++++-- | 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/CmdArgs.hs view
@@ -0,0 +1,140 @@++{-# 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)++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 }+ + | Packup { verbose :: Bool + , server :: String+ , candidate :: Bool+ , user :: Maybe String + , password :: Maybe String+ , file :: 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 x = x &= typ "URL"++{-# INLINE userArg #-}+userArg x = x &= typ "USER"++{-# INLINE passwdArg #-}+passwdArg x = x &= typ "PASSWORD"++{-# INLINE fileArg #-}+fileArg x = x &= typ "FILE" ++{-# INLINE verbArgs #-}+verbArgs x = x &= help "be verbose" ++-- commands that can be run++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)."])++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 =+ Docup + { server = serverArg defaultServer + ,file = fileArg def &= argPos 0 + }+ &= help "Upload FILE as documentation."++docboth = + Docboth + {}+ &= help "Build and upload documentation for a package."++-- Process command-line arguments+processArgs = do+ args <- getArgs+ -- If the user did not specify any arguments, pretend as "--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 [packup + ,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 view
@@ -0,0 +1,112 @@++{-# 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 view
@@ -0,0 +1,13 @@+++module DefaultServerUrl where+++defaultServerUrl :: String+defaultServerUrl = "https://hackage.haskell.org/"+--defaultServerUrl = "http://localhost:8080/"+++++
+ src/Main.hs view
@@ -0,0 +1,316 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}++module Main where++import Prelude hiding (FilePath)+import qualified Prelude++import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Reader (MonadReader(..), runReaderT, liftM)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Except (ExceptT(..),runExceptT,throwE)+import Data.Char (isSpace, isDigit)+import Data.Either (either)+import Data.List (isPrefixOf)+import Data.Maybe (isNothing)+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Monoid ( (<>) )+import Shelly.Lifted+import System.Directory -- (listDirectory)+import System.IO (hSetBuffering, BufferMode( LineBuffering )+ , stdout)++import Distribution.Hup ( Package(..),IsDocumentation(..)+ ,IsCandidate(..),Auth(..),Upload(..)+ ,mkAuth ,buildTar+ ,readCabal, extractCabal+ ,parseTgzFilename' + , getUploadUrl)+import CmdArgs (HupCommands(..), isUpload, processArgs)+import SanityCheck (sanity)+import Upload (doUpload)++#if MIN_VERSION_directory(1,2,5)+#else+listDirectory :: Prelude.FilePath -> IO [Prelude.FilePath]+listDirectory path =+ filter f <$> getDirectoryContents path+ where f filename = filename /= "." && filename /= ".."+#endif++-- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m,+-- 'MonadShControl' m+type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m) ++-- | 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)++rstrip :: Text -> Text+rstrip = T.dropWhileEnd isSpace ++-- | does haddock have ability to do hyperlinked source.+haddockCanHyperlinkSrc :: MonadShellish m => m Bool+haddockCanHyperlinkSrc = errExit False $ do+ run_ "haddock" ["--hyperlinked-source"]+ (==0) `liftM` lastExitCode++-- | safe version of "maximum"+maxMay xs = if null xs then Nothing else Just $ maximum xs++-- | look for ghc & try to add it to path+addGhcPath :: MonadShellish m => m ()+addGhcPath = + -- see if ghc is already in path;+ -- if not, try looking for it in stack's "programs" directory.+ whenM (isNothing `liftM` which "ghc") $ do+ progPath <- rstrip <$> silently (run "stack" ["path", "--programs"])+ let myFilt x = "ghc" `isPrefixOf` x && isDigit (last x)+ ghcDir <- liftIO $ (maxMay . filter myFilt) `liftM` listDirectory (T.unpack progPath)+ case ghcDir of+ Nothing -> terror "couldn't find ghc on path, please add it"+ Just ghcDir' -> appendToPath $ progPath </> ghcDir' </> "bin"+++-- | Run commands for building documentation tgz. 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 dir pkg CandidatePkg` will build documentation in the+-- directory `dir`, and will return an `Upload` object, which can be uploaded+-- with `Distribution.Hup.Upload.doUpload`.+--+-- Requires that stack, haddock and cabal be on the path.+--+-- Sample usage:+--+-- > import Distribution.Hup.Upload +-- > :set -XOverloadedStrings +-- > let p = Package "foo" "0.1"+-- > upload <- shelly $ stackBuildDocs "." p CandidatePkg +-- > 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 dir (Package pkg ver) = do+ hc <- ask+ -- work out flags to call with ...+ canHyperlink <- haddockCanHyperlinkSrc + let hyperlinkFlag = if canHyperlink+ then ["--haddock-option=--hyperlinked-source"]+ else []+ unless (quick hc) $ do+ echo "build dependencies docs"+ run_ "stack" ["haddock", "--only-dependencies"]+ snapshotpkgdb <- rstrip <$> silently (run "stack" ["path", "--snapshot-pkg-db"])+ localpkgdb <- rstrip <$> silently (run "stack" ["path", "--local-pkg-db"])+ let verboseCommands = if verbose hc then ["-v2"] else [] + let haddockExtraArgs = 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 [])+ let cabalExtraArgs =(if tests hc then ["--enable-tests"] else [])+ echo "configuring"+ let builddir= toTextIgnore $ dir </> "dist"+ run_ "cabal" $["configure", "--builddir="<>builddir, + "--package-db=clear", "--package-db=global", + "--package-db=" <> snapshotpkgdb, + "--package-db=" <> localpkgdb] ++ verboseCommands+ ++ cabalExtraArgs+ echo "making docs"+ run_ "cabal" $["haddock", "--builddir=" <> builddir, + "--html-location=/package/$pkg-$version/docs",+ "--contents-location=/package/$pkg-$version"] + ++ hyperlinkFlag ++ verboseCommands+ ++ haddockExtraArgs + pkg <- return $ T.pack pkg+ ver <- return $ T.pack ver+ let srcDir = builddir </> "doc" </> "html" </> pkg+ tgtDir = dir </> (pkg <> "-" <> ver <> "-docs")+ cp_r srcDir tgtDir+ echo "tarring"+ let+ up = T.unpack+ fromPath = T.unpack . toTextIgnore + docTgz = fromPath $ dir </> (pkg<>"-"<>ver <> "-docs.tar.gz") + docDir = pkg <> "-" <> ver <> "-docs" + -- 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 dir) [up docDir]+ return $ Upload (Package (up pkg) (up ver)) docTgz Nothing IsDocumentation (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 hc = + if candidate hc+ then CandidatePkg+ else NormalPkg +++fromString = fromText . T.pack++-- | check that stack, cabal & haddock are on path+checkPrereqs :: MonadSh m => m ()+checkPrereqs = do+ whenM (isNothing <$> which "stack") $ do+ echo "Couldn't find stack on path - do you need to install stack?"+ quietExit 1+ whenM (isNothing <$> which "cabal") $ do+ echo $ T.unwords ["Couldn't find cabal on path - do you need to"+ ,"run 'stack install cabal-install'? Exiting"]+ quietExit 1+ whenM (isNothing <$> which "haddock") $ do+ echo $ T.unwords ["Couldn't find haddock on path - do you need to"+ ,"run 'stack install haddock'? Exiting"]+ quietExit 1+++-- | 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+ withTmpDir $ \tmpDir -> + 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+ _ -> return () -- i.e. carry on.+ -- if still here, we've been asked to do a build.+ uploadable <- do let p = Package packageName packageVer+ buildRes <- lift $ stackBuildDocs tmpDir p + let tgzFile = fromText $ T.pack $ fileToUpload buildRes + case hc of + Docbuild {} -> lift (cp tgzFile ".") >>+ throwE Done+ _ -> 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++++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hupCommand <- sanity =<< processArgs+ let verbosify = if verbose hupCommand+ then verbosely+ else id+ shelly $ do+ silently checkPrereqs+ verbosify $ do + addGhcPath+ runReaderT mainSh hupCommand + return ()+++
+ src/SanityCheck.hs view
@@ -0,0 +1,57 @@++++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 (whenM, unlessM)+import System.Directory (makeAbsolute,doesFileExist ) +import System.Exit++import CmdArgs (HupCommands(..))+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?+sanity :: HupCommands -> IO HupCommands+sanity hc = do+ 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+ Docbuild {} -> return hc+ Docboth {} -> return hc+ _ -> 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'+++++++++
+ src/Types.hs view
@@ -0,0 +1,25 @@++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 view
@@ -0,0 +1,89 @@++{-# 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+ displayResponse `liftM` sendRequest req++++-- | 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.yaml view
@@ -0,0 +1,32 @@+resolver: lts-7.14+#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: []+
+ test/Distribution/Hup/Parse/Test.hs view
@@ -0,0 +1,65 @@+++{- |++Support code for testing Distribution.Hup.Parse ++-}+module Distribution.Hup.Parse.Test where++import Data.List (dropWhileEnd,isSuffixOf,stripPrefix+ ,intercalate)+import Data.ByteString.Lazy.Char8 (pack)+import Test.QuickCheck++import Distribution.Hup.Parse+++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 = 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 = + 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/Distribution/Hup/ParseSpec.hs view
@@ -0,0 +1,33 @@+++module Distribution.Hup.ParseSpec where++import Test.Hspec+import Test.QuickCheck++import Distribution.Hup.Parse++import Data.List (dropWhileEnd,isSuffixOf,stripPrefix+ ,intercalate)+import Data.ByteString.Lazy.Char8 (pack)++import qualified Distribution.Hup.Parse.Test++arbWord = Distribution.Hup.Parse.Test.arbWord ++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/Distribution/Hup/Upload/Test.hs view
@@ -0,0 +1,100 @@+{-# 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 +import Distribution.Hup.Parse.Test++type ParsedTgz = Either String (IsDocumentation, Package) ++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 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 sendRequest port upl auth = do+ 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/Distribution/Hup/UploadSpec.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedStrings #-}++module Distribution.Hup.UploadSpec where+++++import Control.Exception (throwIO)+import Control.Monad+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+ ,StdMethod(..)) +import Network.Wai.Parse as Parse (FileInfo(..), fileName)+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 Web.Frank --(post, put)+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.Test++import qualified Distribution.Hup.Upload.Test ++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.+ Distribution.Hup.WebTest.liveTest webApp++++httpMetadataRoundtripsOK' = + forAll arbUpload $ \upl -> httpMetadataRoundtripsOK upl +++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++--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 = + 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 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)++++++
+ test/Distribution/Hup/WebTest.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Distribution.Hup.WebTest where+++import Distribution.Hup.Upload +import Distribution.Hup.Upload.Test+import Distribution.Hup.Parse +import Network.Wai (Application)+import Test.Hspec+import Test.QuickCheck++#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 = 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++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" $ + it "should send to the right web app path" $ \(port, sock, tid) -> + httpRoundTripsOK' sendRequest port ++ context "when given a bad URL" $ + it "should not throw an exception" $ \(port, sock, tid) -> + badUrlReturns' sendRequest port ++#else++liveTest :: Application -> SpecWith ()+liveTest _ = return ()++#endif++++
+ test/DocTest.hs view
@@ -0,0 +1,7 @@++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "lib/**/*.hs" >>= doctest+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}