diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,120 @@ +# hup [![Hackage version](https://img.shields.io/hackage/v/hup.svg?label=Hackage)](https://hackage.haskell.org/package/hup) [![Linux Build Status](https://img.shields.io/travis/phlummox/hup.svg?label=Linux%20build)](https://travis-ci.org/phlummox/hup) [![Windows Build Status](https://img.shields.io/appveyor/ci/phlummox/hup.svg?label=Windows%20build)](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 + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hup.cabal b/hup.cabal new file mode 100644 --- /dev/null +++ b/hup.cabal @@ -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 + + diff --git a/lib/Distribution/Hup.hs b/lib/Distribution/Hup.hs new file mode 100644 --- /dev/null +++ b/lib/Distribution/Hup.hs @@ -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 + diff --git a/lib/Distribution/Hup/BuildTar.hs b/lib/Distribution/Hup/BuildTar.hs new file mode 100644 --- /dev/null +++ b/lib/Distribution/Hup/BuildTar.hs @@ -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 + + diff --git a/lib/Distribution/Hup/Parse.hs b/lib/Distribution/Hup/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/Distribution/Hup/Parse.hs @@ -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 +-- +-- >>> 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 +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 +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 +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 + + + + diff --git a/lib/Distribution/Hup/Types.hs b/lib/Distribution/Hup/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Distribution/Hup/Types.hs @@ -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) + + diff --git a/lib/Distribution/Hup/Upload.hs b/lib/Distribution/Hup/Upload.hs new file mode 100644 --- /dev/null +++ b/lib/Distribution/Hup/Upload.hs @@ -0,0 +1,252 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE CPP #-} + +{-| + +Handle uploading to a hackage server, using the @HTTP@ API described +in the +. + +-} + +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 +-- '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" + + + diff --git a/src/CmdArgs.hs b/src/CmdArgs.hs new file mode 100644 --- /dev/null +++ b/src/CmdArgs.hs @@ -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." ] + diff --git a/src/CmdArgs/PatchHelp.hs b/src/CmdArgs/PatchHelp.hs new file mode 100644 --- /dev/null +++ b/src/CmdArgs/PatchHelp.hs @@ -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 " + +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 + diff --git a/src/DefaultServerUrl.hs b/src/DefaultServerUrl.hs new file mode 100644 --- /dev/null +++ b/src/DefaultServerUrl.hs @@ -0,0 +1,13 @@ + + +module DefaultServerUrl where + + +defaultServerUrl :: String +defaultServerUrl = "https://hackage.haskell.org/" +--defaultServerUrl = "http://localhost:8080/" + + + + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 () + + + diff --git a/src/SanityCheck.hs b/src/SanityCheck.hs new file mode 100644 --- /dev/null +++ b/src/SanityCheck.hs @@ -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' + + + + + + + + + diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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) + + + + diff --git a/src/Upload.hs b/src/Upload.hs new file mode 100644 --- /dev/null +++ b/src/Upload.hs @@ -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 = ["