hup 0.2.0.0 → 0.3.0.0
raw patch · 28 files changed
+1027/−636 lines, 28 filesdep +hspec-coredep ~Globdep ~QuickCheckdep ~base
Dependencies added: hspec-core
Dependency ranges changed: Glob, QuickCheck, base, bytestring, directory, doctest, filepath, hspec, hspec-wai, http-client, http-client-tls, http-types, mtl, network, shelly, simple, split, tagsoup, tar, temporary, text, transformers, vector, wai, wai-extra, warp, zlib
Files
- ChangeLog.md +19/−0
- README.md +38/−6
- hup.cabal +9/−6
- lib/Distribution/Hup.hs +0/−1
- lib/Distribution/Hup/Parse.hs +4/−5
- lib/Distribution/Hup/Upload.hs +15/−11
- src-doctest/DocTest.hs +7/−0
- src-hspec-test/Distribution/Hup/Parse/Test.hs +64/−0
- src-hspec-test/Distribution/Hup/ParseSpec.hs +25/−0
- src-hspec-test/Distribution/Hup/Upload/Test.hs +99/−0
- src-hspec-test/Distribution/Hup/UploadSpec.hs +173/−0
- src-hspec-test/Distribution/Hup/WebTest.hs +81/−0
- src-hspec-test/Spec.hs +1/−0
- src/CmdArgs.hs +73/−3
- src/DefaultServerUrl.hs +1/−1
- src/DocBuilding.hs +207/−0
- src/Main.hs +75/−132
- src/SanityCheck.hs +23/−16
- src/Stack.hs +107/−0
- src/Upload.hs +5/−2
- stack.yaml +1/−1
- test/Distribution/Hup/Parse/Test.hs +0/−65
- test/Distribution/Hup/ParseSpec.hs +0/−33
- test/Distribution/Hup/Upload/Test.hs +0/−100
- test/Distribution/Hup/UploadSpec.hs +0/−176
- test/Distribution/Hup/WebTest.hs +0/−70
- test/DocTest.hs +0/−7
- test/Spec.hs +0/−1
+ ChangeLog.md view
@@ -0,0 +1,19 @@+## 0.2.0.0++* Bug fixes+* Allow an Upload to store contents of file to be uploaded.+* Support older versions of directory and http-client+* Allow extra args to be passed to cabal when configuring or when+ running haddock.+* Added hspec and docstring tests+* Now running travis CI on a range of platforms and ghc versions.++## 0.3.0.0++* Bug fixes+* Updated documentation, added a "quick usage" section and troubleshooting+* `hup` now checks whether `cabal` is in the package snapshot binaries+ directory, and installs it if not.+* Added `packbuild` and `packboth` commands.+* Added a program test to .travis.yml+
README.md view
@@ -1,19 +1,29 @@-# hup [](https://hackage.haskell.org/package/hup) [](https://travis-ci.org/phlummox/hup) [](https://ci.appveyor.com/project/phlummox/hup)+# hup [](https://hackage.haskell.org/package/hup) [](https://travis-ci.org/phlummox/hup) Small program for building and uploading packages and documentation built with `stack` to a hackage server; a Haskellified version of [phadej's script](https://github.com/phadej/binary-orphans/blob/master/hackage-docs.sh), which is a stack-enabled version of [ekmett's script](https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh). -In addition to `stack`, 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`.)+In addition to `stack`, it requires the `cabal` executable+(but will install an appropriate `cabal` if it doesn't find one in the+binaries for the package snapshot your project is using). ## Installation -Install in the standard Haskell way: `cabal install hup`, or `stack-install hup`.+Install in the standard Stack way with `stack install hup`. +## Quick usage++Try:++~~~ +$ cd /path/to/my/project+$ stack build+$ hup packboth -u myHackageUserID -p myHackagePassword+$ hup docboth -u myHackageUserID -p myHackagePassword +~~~+ ## Usage * `hup [COMMAND] ... [OPTIONS]`@@ -95,6 +105,28 @@ -c --candidate -u --user=USER -p --password=PASSWORD ++## Troubleshooting++### I get an error during upload that says "...: does not exist (no such protocol name: tcp)"++This is not actually a bug in `hup`, but is found in e.g. Docker containers+that don't have all the packages needed for networking - see e.g. +[here](https://stackoverflow.com/questions/46322773/yesod-app-in-docker-container-cant-make-network-requests) on StackOverflow.++You will need to install networking packages appropriate for your distro - on Ubuntu, something like ca-certificates, libgnutls28 (or another version of the GNU TLS library), and netbase. ++### I get some sort of error when building documents that says "...haddock: internal error: ... hGetContents: invalid argument (invalid byte sequence)"++Again, this isn't actually a bug in `hup`, but happens (e.g. in Docker+containers) when the system locale is not properly set up (see a bug report+[here](https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=871839) arising from a+similar issue). Annoyingly, `haddock` depends on the locale being properly set,+though it doesn't really seem necessary.++Try running `locale-gen "en_US.UTF-8"` to generate an appropriate UTF-8+locale, and `export LC_ALL="en_US.UTF-8"` so that the locale can be found+from environment variables. ## Bash command-line completion
hup.cabal view
@@ -1,5 +1,5 @@ name: hup-version: 0.2.0.0+version: 0.3.0.0 synopsis: Upload packages or documentation to a hackage server description: Upload packages or documentation to a hackage server@@ -15,7 +15,7 @@ build-type: Simple tested-with: GHC == 8.0.1, GHC == 7.10.3 cabal-version: >=1.10-extra-source-files: README.md, stack.yaml +extra-source-files: README.md, stack.yaml, ChangeLog.md Flag EnableWebTests Description: Enable tests that do a (pretty minimal) check by running an actual@@ -67,6 +67,8 @@ , SanityCheck , Types , Upload+ , Stack+ , DocBuilding if flag(PatchHelpMessage) other-modules: CmdArgs.PatchHelp cpp-options: -DPATCH_HELP@@ -79,16 +81,16 @@ , bytestring , directory , mtl- , shelly >= 1.6.5- -- shelly - higher possibly needed?+ , shelly >= 1.6.6 , tagsoup+ -- , temporary >= 1.2.1 , text , transformers , hup test-suite hup-spec type: exitcode-stdio-1.0- hs-source-dirs: test+ hs-source-dirs: src-hspec-test main-is: Spec.hs build-depends: base@@ -99,6 +101,7 @@ , http-types , hup , hspec+ , hspec-core , QuickCheck , simple , temporary@@ -128,7 +131,7 @@ test-suite hup-doctest type: exitcode-stdio-1.0- hs-source-dirs: test+ hs-source-dirs: src-doctest main-is: DocTest.hs build-depends: base , hup
lib/Distribution/Hup.hs view
@@ -42,6 +42,5 @@ import Distribution.Hup.BuildTar import Distribution.Hup.Parse-import Distribution.Hup.Types import Distribution.Hup.Upload
lib/Distribution/Hup/Parse.hs view
@@ -12,7 +12,6 @@ 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)@@ -122,7 +121,7 @@ extractCabal find = f . words . replace ":" " : " where f (name:":":val:_) | map toLower find == map toLower name = val- f (x:xs) = f xs+ 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 @@ -136,9 +135,9 @@ (base, ext) <- return $ splitExtension base ext `shouldBe` ".tar" base <- return $ snd $ splitFileName base- let isDocco = if "-docs" `isSuffixOf` base- then IsDocumentation - else IsPackage+ --let isDocco = if "-docs" `isSuffixOf` base+ -- then IsDocumentation + -- else IsPackage (base, isDocco) <- return $ if "-docs" `isSuffixOf` base then let base' = intercalate "-" $ init $ splitOn "-" base
lib/Distribution/Hup/Upload.hs view
@@ -22,10 +22,9 @@ import qualified Data.ByteString.Builder as Bu import Data.List (dropWhileEnd) import Data.Maybe (fromJust)-import Data.ByteString.Char8 (pack,unpack,putStrLn,ByteString(..) )+import Data.ByteString.Char8 (pack,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(..)@@ -40,6 +39,7 @@ import Distribution.Hup.Types -- for re-export +import Control.Exception #if MIN_VERSION_http_client(0,4,30)@@ -156,15 +156,19 @@ 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+-- | Send an HTTP request and get the response (or an exception)+sendRequest :: Request -> IO (Either C.HttpException Response) +sendRequest req = + do+ man <- C.newManager tlsManagerSettings+ tryHttp (mkResponse <$> C.httpLbs req man) + where+ --idHttp :: (C.HttpException -> IO a) -> (C.HttpException -> IO a) + --idHttp = id++ tryHttp :: IO a -> IO (Either C.HttpException a) + tryHttp = try+
+ src-doctest/DocTest.hs view
@@ -0,0 +1,7 @@++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "lib/**/*.hs" >>= doctest+
+ src-hspec-test/Distribution/Hup/Parse/Test.hs view
@@ -0,0 +1,64 @@+++{- |++Support code for testing Distribution.Hup.Parse ++-}+module Distribution.Hup.Parse.Test where++import Data.List (intercalate)+import Data.ByteString.Lazy.Char8 (pack)+import Test.QuickCheck++import Distribution.Hup.Parse+++arbWord = 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+++
+ src-hspec-test/Distribution/Hup/ParseSpec.hs view
@@ -0,0 +1,25 @@+++module Distribution.Hup.ParseSpec where++import Test.Hspec+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++
+ src-hspec-test/Distribution/Hup/Upload/Test.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++{- | Support for testing Distribution.Hup.Upload ++-}++module Distribution.Hup.Upload.Test where++import qualified Data.ByteString.Lazy.Char8 as LBS -- pack+import qualified Network.HTTP.Client as HTTP.Client+import System.FilePath ( (</>) )+import System.IO.Temp (withSystemTempDirectory)+import Test.QuickCheck+import Test.QuickCheck.Monadic (run, assert, monadicIO)++import Distribution.Hup.Upload +import Distribution.Hup.Parse.Test++type ParsedTgz = Either String (IsDocumentation, Package) ++arbAuth =+ 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 = + monadicIO $ do+ response <- run $ badRequest port upl auth+ assert $ statusCode response /= 200++ where+ badRequest :: Int -> Upload -> Maybe Auth -> IO Response+ badRequest port upl auth = + withSystemTempDirectory "huptest" $ \tmpDir -> do+ let newFile = tmpDir </> fileToUpload upl+ upl <- return $ upl { fileToUpload = newFile } + writeFile (tmpDir </> fileToUpload upl) ""+ let url = "http://localhost:" ++ show port ++ "/fubar/"+ buildRequest url upl auth >>= sendRequest++++
+ src-hspec-test/Distribution/Hup/UploadSpec.hs view
@@ -0,0 +1,173 @@+{-# 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.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.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)++++++
+ src-hspec-test/Distribution/Hup/WebTest.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Distribution.Hup.WebTest where+++import Distribution.Hup.Upload (sendRequest) +import Distribution.Hup.Upload.Test+import Distribution.Hup.Parse +import Network.Wai (Application)+import Test.Hspec+import Test.Hspec.Core.QuickCheck (modifyMaxSuccess)+import Test.QuickCheck++#ifdef WEB_TESTS++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++-- Pulls a "Right" value out of an Either value. If the Either value is+-- Left, raises an exception with "error".+forceEither :: Show e => Either e a -> a+forceEither (Left x) = error (show x)+forceEither (Right x) = x++startServer :: Application -> IO (Port, Soc.Socket, ThreadId)+startServer webApp = do+ (port, sock) <- openFreePort + tid <- forkIO $ runSettingsSocket defaultSettings sock webApp+ return (port, sock, tid) ++shutdownServer :: (Port, Soc.Socket, ThreadId) -> IO ()+shutdownServer (_port, sock, _tid) = + Soc.close sock++liveTest :: Application -> SpecWith ()+liveTest webApp = do+ beforeAll (startServer webApp) $ afterAll shutdownServer $ + describe "buildRequest" $ do+ context "when its result is fed into sendRequest" $ + modifyMaxSuccess (const 50) $+ it "should send to the right web app path" $ \(port, sock, tid) -> + httpRoundTripsOK' sendRequest' port++ context "when given a bad URL" $ + modifyMaxSuccess (const 50) $+ it "should not throw an exception" $ \(port, sock, tid) -> + badUrlReturns' sendRequest' port++sendRequest' req = forceEither <$> sendRequest req+++#else++liveTest :: Application -> SpecWith ()+liveTest _ = return ()++#endif+++
+ src-hspec-test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
src/CmdArgs.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-cse #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# LANGUAGE ViewPatterns #-} module CmdArgs where @@ -13,6 +14,34 @@ import qualified DefaultServerUrl import CmdArgs.PatchHelp (cmdArgs) +isDoc :: HupCommands -> Bool+isDoc cmd = case cmd of+ Docbuild {} -> True+ Docboth {} -> True+ _ -> False++isBuild :: HupCommands -> Bool+isBuild cmd = case cmd of+ Docbuild {} -> True+ Packbuild {} -> True+ _ -> False++isBoth :: HupCommands -> Bool+isBoth cmd = case cmd of+ Docboth {} -> True+ Packboth {} -> True+ _ -> False++isUp :: HupCommands -> Bool+isUp cmd = case cmd of+ Docup {} -> True+ Packup {} -> True+ _ -> False+++++defaultServer :: String defaultServer = DefaultServerUrl.defaultServerUrl -- | Actions the program can perform@@ -33,6 +62,8 @@ , candidate :: Bool , user :: Maybe String , password :: Maybe String }++ | Packbuild { verbose :: Bool } | Packup { verbose :: Bool , server :: String@@ -40,6 +71,14 @@ , user :: Maybe String , password :: Maybe String , file :: String }++ | Packboth { verbose :: Bool + , server :: String+ , candidate :: Bool+ , user :: Maybe String + , password :: Maybe String+ }+ | Docup { verbose :: Bool , server :: String , candidate :: Bool@@ -56,22 +95,36 @@ -- arguments. {-# INLINE serverArg #-}+serverArg :: Data val => val -> val serverArg x = x &= typ "URL" {-# INLINE userArg #-}+userArg :: Data val => val -> val userArg x = x &= typ "USER" {-# INLINE passwdArg #-}+passwdArg :: Data val => val -> val passwdArg x = x &= typ "PASSWORD" {-# INLINE fileArg #-}+fileArg :: Data val => val -> val fileArg x = x &= typ "FILE" {-# INLINE verbArgs #-}+verbArgs :: Data val => val -> val verbArgs x = x &= help "be verbose" -- commands that can be run +packbuild :: HupCommands+packbuild =+ Packbuild+ { verbose = verbArgs def+ }+ &= help "Build source distribution .tgz for a package."+++packup :: HupCommands packup = Packup { verbose = verbArgs def@@ -81,8 +134,20 @@ ,user = userArg Nothing ,password = passwdArg Nothing } &= help (unwords ["Upload FILE as a package (or"- ,"candidate package)."])+ ,"candidate package)."]) +packboth :: HupCommands+packboth =+ Packboth+ { verbose = verbArgs def+ ,server = serverArg defaultServer + ,candidate = def + ,user = userArg Nothing + ,password = passwdArg Nothing }+ &= help (unwords ["Build source distribution .tgz and upload"+ ,"as package (or candidate package)."])++docbuild :: HupCommands docbuild = Docbuild { verbose = verbArgs def@@ -100,6 +165,7 @@ } &= help "Build documentation for a package." +docup :: HupCommands docup = Docup { server = serverArg defaultServer @@ -107,21 +173,25 @@ } &= help "Upload FILE as documentation." +docboth :: HupCommands docboth = Docboth {} &= help "Build and upload documentation for a package." -- Process command-line arguments+processArgs :: IO HupCommands processArgs = do args <- getArgs- -- If the user did not specify any arguments, pretend as "--help" was given+ -- If the user did not specify any arguments, pretend "--help" was given (if null args then withArgs ["--help"] else id) proc where proc :: IO HupCommands proc = cmdArgs $ -- commands that can be run, i.e. "modes"- modes [packup + modes [packbuild+ ,packup + ,packboth ,docbuild -- &= groupname "A" ,docup -- &= groupname "B" ,docboth ] -- &= groupname "C"]
src/DefaultServerUrl.hs view
@@ -2,7 +2,7 @@ module DefaultServerUrl where -+-- | The default hackage server URL. defaultServerUrl :: String defaultServerUrl = "https://hackage.haskell.org/" --defaultServerUrl = "http://localhost:8080/"
+ src/DocBuilding.hs view
@@ -0,0 +1,207 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++{- |++Knowledge of the arcane and cryptic commands to be run to get+haddock docs properly built.++-}++module DocBuilding +(+-- * given a 'HupCommand', what arguments are needed+ verbosityArgs+ , haddockExtraArgs + , cabalExtraArgs +-- * actions+ , buildDependencyDocs+ , cabalConfigure+ , cabalHaddock+ , doBuildTar+-- * top-level action+ , buildDocs+-- * path utilities+ , buildDir+)+where++import CmdArgs (HupCommands(..), isUpload, processArgs)+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Monoid ( (<>) )+import Shelly.Lifted+import Data.Char (isSpace)+import Prelude hiding (FilePath)+import Control.Monad.IO.Class ( MonadIO(..) )+import qualified Stack +import Distribution.Hup ( Package(..), buildTar )+import Control.Exception+import Shelly ( ReThrownException ) ++-- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m,+-- 'MonadShControl' m@+type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m) ++rstrip :: Text -> Text+rstrip = T.dropWhileEnd isSpace+++-- | any arguments for cabal deriving from how verbose+-- we've been asked to be+verbosityArgs :: HupCommands -> [Text]+verbosityArgs hc = if verbose hc then ["-v2"] else [] ++-- | arguments to supply directly to haddock, such as "--executables",+-- "--internal", or anything specified by the end user+haddockExtraArgs :: HupCommands -> [Text]+haddockExtraArgs hc = + let args = haddockArgs hc + in (if null args+ then []+ else ["--haddock-options=" <>T.pack(haddockArgs hc)])+ ++ (if executables hc then ["--executables"] else [])+ ++(if tests hc then ["--tests"] else [])+ ++(if internal hc then ["--internal"] else [])++-- | any arguments which need to be supplied to cabal,+-- like "--enable-tests"+cabalExtraArgs :: HupCommands -> [Text]+cabalExtraArgs hc = if tests hc then ["--enable-tests"] else []+++-- | run haddock with "--only-dependencies"+buildDependencyDocs :: MonadSh m => m ()+buildDependencyDocs = do+ run_ "stack" ["haddock", "--only-dependencies"]++-- | given a "base" dir, return the "dist" subdir+-- where built stuff actually gets put.+buildDir :: FilePath -> FilePath+buildDir baseDir = baseDir </> "dist"++-- | run "cabal configure" with appropriate args, prior to+-- running "cabal haddock". cabal should be on path.+--+-- args: @cabalConfigure baseDir cabalExtraArgs verbosityArgs@.+cabalConfigure+ :: MonadShellish m =>+ FilePath -> [Text] -> [Text] -> m ()+cabalConfigure baseDir cabalExtraArgs verbosityArgs = do+ let tt = toTextIgnore + snapshotpkgdb <- rstrip <$> silently (run "stack" ["path", "--snapshot-pkg-db"])+ localpkgdb <- rstrip <$> silently (run "stack" ["path", "--local-pkg-db"])+ run_ "cabal" $ ["configure", "--builddir="<> tt (buildDir baseDir), + "--package-db=clear", "--package-db=global", + "--package-db=" <> snapshotpkgdb, + "--package-db=" <> localpkgdb] ++ verbosityArgs + ++ cabalExtraArgs++-- | run "cabal haddock" with appropriate args. Haddock+-- should be on path.+--+-- args: @cabalHaddock baseDir verbosityArgs haddockExtraArgs@+-- +cabalHaddock+ :: MonadShellish m => FilePath -> [Text] -> [Text] -> m ()+cabalHaddock baseDir verbosityArgs haddockExtraArgs = do+ let tt = toTextIgnore + canHyperlink <- Stack.haddockCanHyperlinkSrc + let hyperlinkArgs = if canHyperlink+ then ["--haddock-option=--hyperlinked-source"]+ else []+ run_ "cabal" $ ["haddock", "--builddir=" <> tt (buildDir baseDir), + "--html-location=/package/$pkg-$version/docs",+ "--contents-location=/package/$pkg-$version"] + ++ hyperlinkArgs ++ verbosityArgs+ ++ haddockExtraArgs +++-- | Tar up the html produced by haddock into a "-docs.tar.gz" file.+-- Returns the path of the tar file that has been built.+--+-- args: @doBuildTar baseDir package@.+doBuildTar :: MonadShellish m => FilePath -> Package -> m FilePath+doBuildTar baseDir (Package pkg_ ver_) = do+ let+ pkg = T.pack pkg_+ ver = T.pack ver_+ fromPath = T.unpack . toTextIgnore + docTgz = fromPath $ baseDir </> (pkg<>"-"<>ver <> "-docs.tar.gz") + docDir = pkg <> "-" <> ver <> "-docs" + -- build tar using pure hs. or, if you have tar on system, could use:+ -- run "tar" ["cvz", "-C", dir, "--format=ustar", "-f", docTgz,+ -- pkg <> "-" <> ver <> "-docs" ]+ liftIO $ buildTar docTgz (fromPath baseDir) [T.unpack docDir]+ return $ fromText $ T.pack docTgz++-- Shelly exceptions end up being (almost) endlessly wrappered IOErrors ...+-- but here's a convenience function for catching what they look like at +-- the top level.+catch_sh_rethrown :: Sh a -> (ReThrownException SomeException -> Sh a) -> Sh a+catch_sh_rethrown = catch_sh++-- | Build a documentation .tgz file.+--+-- A Haskellified version of+-- phadej's script at+--+-- <https://github.com/phadej/binary-orphans/blob/master/hackage-docs.sh>,+--+-- which is a stack-enabled version of ekmett's script at+--+-- <https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh>.+--+-- @stackBuildDocs baseDir pkg@ will build documentation in the+-- directory @baseDir@.+--+-- Requires that stack, haddock and cabal be on the path.+--+-- Sample usage:+--+-- > :set -XOverloadedStrings +-- > let p = Package "foo" "0.1"+-- > shelly $ verbosely $ buildDocs "." p +--+-- When running from within ghci, you may have to unset some+-- environment variables that have been set. Else cabal will complain+-- about them.+--+-- > import System.Environment+-- > import Control.Monad+-- > mapM_ unsetEnv ["HASKELL_PACKAGE_SANDBOXES", "GHC_PACKAGE_PATH", "HASKELL_PACKAGE_SANDBOX", "STACK_EXE", "HASKELL_DIST_DIR"]+--+buildDocs+ :: MonadShellish m =>+ HupCommands -> FilePath -> Package -> m FilePath+buildDocs hc tmpDir pkg = + do+ unless (quick hc) $ do+ echo "building dependency docs"+ buildDependencyDocs+ echo "configuring"+ cabalConfigure tmpDir (verbosityArgs hc) (cabalExtraArgs hc)+ echo "running haddock"+ cabalHaddock tmpDir (verbosityArgs hc) (haddockExtraArgs hc)+ echo "copying html files"+ copyHtmlDir (toTextIgnore tmpDir) pkg+ echo "building tar file"+ doBuildTar tmpDir pkg+ where+ -- copy the html files from where haddock puts them to + -- somewhere we can tar them from.+ copyHtmlDir :: MonadShellish m => Text -> Package -> m ()+ copyHtmlDir baseDir (Package pkg_ ver_) = do+ let pkg = T.pack pkg_+ ver = T.pack ver_+ srcDir = baseDir </> "dist" </> "doc" </> "html" </> pkg+ tgtDir = baseDir </> (pkg <> "-" <> ver <> "-docs")+ echo $ "copying from " <> (toTextIgnore srcDir) <> " to " <> (toTextIgnore tgtDir)+ liftSh $ catch_sh_rethrown (errExit False $ cp_r srcDir tgtDir) $ \e -> do+ echo $ T.unwords ["hup: Encountered exception trying to copy html"+ , "documentation:", T.pack $ show e ]+ quietExit 1+
src/Main.hs view
@@ -5,6 +5,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Main where@@ -12,93 +14,56 @@ import Prelude hiding (FilePath) import qualified Prelude +import Control.Monad import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.Reader (MonadReader(..), runReaderT, liftM)+import Control.Monad.Reader (MonadReader(..), runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Except (ExceptT(..),runExceptT,throwE)-import Data.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 qualified System.IO.Temp as Tmp import Distribution.Hup ( Package(..),IsDocumentation(..) ,IsCandidate(..),Auth(..),Upload(..)- ,mkAuth ,buildTar+ ,mkAuth ,readCabal, extractCabal ,parseTgzFilename' , getUploadUrl)-import CmdArgs (HupCommands(..), isUpload, processArgs)+import CmdArgs (HupCommands(..), isUpload, processArgs+ ,isBuild, isBoth, isDoc)+import DocBuilding (buildDocs) import SanityCheck (sanity)+import qualified Stack 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`.+-- | Build documentation tgz, return an Upload value,+-- return an Upload value, ready to be uploaded. (Or not, as desired.) ----- Requires that stack, haddock and cabal be on the path.+-- This installs cabal-install if it is not found in the snapshot+-- binaries, and adds the path to the cabal executable, and to+-- haddock, to the path. -- -- Sample usage: -- -- > import Distribution.Hup.Upload -- > :set -XOverloadedStrings -- > let p = Package "foo" "0.1"--- > upload <- shelly $ stackBuildDocs "." p CandidatePkg +-- > let d = Docbuild { verbose = True }+-- > upload <- shelly $ verbosely $ runReaderT (stackBuildDocs "." p) d -- > doUpload "http://localhost:8080" upload (mkAuth "myname" "mypass") -- -- When running from within ghci, you may have to unset some@@ -107,58 +72,41 @@ -- > 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+stackBuildDocs tmpDir pkg = do hc <- ask+ -- check paths for the tools we need+ Stack.addHaddockPath+ echo "checking for cabal"+ haveCabal <- Stack.cabalInstalled+ unless haveCabal $ do+ echo "didn't find 'cabal' binary in snapshot directory - installing it"+ Stack.installCabal+ Stack.addCabalPath+ -- build the tgz file+ docTgz <- toTextIgnore <$> buildDocs hc tmpDir pkg+ -- return an Upload value, ready to be uploaded. (Or not, as desired.)+ return $ Upload pkg (T.unpack docTgz) Nothing IsDocumentation (isCand hc)+++-- | run "stack sdist" and copy tarball to current dir.+--+-- sample use - something like:+--+-- > let p = Package "foo" "0.1"+-- > let d = Pacbuild { verbose = True }+-- > shelly $ verbosely $ runReaderT (stackSourceDist p) d+--+stackSourceDist :: MonadHup m => Package -> m Upload+stackSourceDist p@(Package pkg ver) = do -- work out flags to call with ...- 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)+ hc <- ask+ run_ "stack" ["sdist"] -- if there are errors, just let them+ -- be re-thrown+ distDir <- Stack.extractPath =<< run "stack" ["path", "--dist-dir"]+ let tgzFile = pkg <> "-" <> ver <> ".tar.gz"+ cp (distDir </> tgzFile) "."+ return $ Upload p tgzFile Nothing IsPackage (isCand hc) -- | if we have a username, then we need to get@@ -174,7 +122,6 @@ Nothing -> terror "username specified, but no password" Just p -> MaybeT $ return $ mkAuth u (T.unpack p) - -- Use for "early return" data Done = Done@@ -190,30 +137,12 @@ done :: Monad m => ExceptT Done m a done = throwE Done +isCand :: HupCommands -> IsCandidate 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. --@@ -262,13 +191,20 @@ -- -- sample usage: ----- > let d = Docbuild { verbose == True }+-- > let d = Docbuild { verbose = True } -- > shelly $ verbosely $ runReaderT $ mainSh d mainSh :: MonadHup m => m () mainSh = do hc <- ask- withTmpDir $ \tmpDir -> - runEarlyReturn $ do+ --tmpBase <- liftIO $ Tmp.getCanonicalTemporaryDirectory+ --tmpDir <- fromText . T.pack <$> liftIO (Tmp.createTempDirectory tmpBase "hup")+ --do++ -- * Bug intermittently occurred where this temp directory disappeared+ -- partway thru mainSh running. Might've been caused by something+ -- not being strict enough? This seems to fix it, so far *shrug*+ withTmpDir $ \tmpDir -> do + !res <- runEarlyReturn $ do cabalConts <- liftIO readCabal let packageName = extractCabal "name" cabalConts packageVer = extractCabal "version" cabalConts @@ -277,14 +213,22 @@ throwE Done Docup {} -> do uploadTgz IsDocumentation "documentation" throwE Done- _ -> return () -- i.e. carry on.+ (isBuild -> True) -> return () -- i.e. carry on.+ (isBoth -> True) -> return ()+ _ -> error "match error" -- if still here, we've been asked to do a build. uploadable <- do let p = Package packageName packageVer- buildRes <- lift $ stackBuildDocs tmpDir p - let tgzFile = fromText $ T.pack $ fileToUpload buildRes + buildRes <- case hc of + (isDoc -> True) -> lift $ stackBuildDocs tmpDir p+ _ -> lift $ stackSourceDist p+ + let tgzFile = fromText $ T.pack $ fileToUpload buildRes+ case hc of + Packbuild {} -> throwE Done -- build only Docbuild {} -> lift (cp tgzFile ".") >>- throwE Done+ throwE Done -- no need to upload,+ -- only build requested _ -> return buildRes auth <- lift $ getAuth hc let url = getUploadUrl (server hc) uploadable@@ -295,6 +239,7 @@ throwE Done Right msg -> lift $ do echo "Uploaded successfully" echo $ "mesg was: " <> T.pack msg+ return () @@ -306,9 +251,7 @@ then verbosely else id shelly $ do- silently checkPrereqs verbosify $ do - addGhcPath runReaderT mainSh hupCommand return ()
src/SanityCheck.hs view
@@ -1,5 +1,7 @@ -+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module SanityCheck where @@ -8,11 +10,11 @@ import Control.Monad.Trans.Except (ExceptT(..),runExceptT, throwE) import Data.Monoid ( (<>) )-import Shelly (whenM, unlessM)+import Shelly (unlessM) import System.Directory (makeAbsolute,doesFileExist ) import System.Exit -import CmdArgs (HupCommands(..))+import CmdArgs (HupCommands(..), isBoth, isBuild, isUp) import CmdArgs.PatchHelp (cmdArgs) -- TODO:@@ -22,12 +24,16 @@ -- - will ignore the sensibleness of haddockArgs, users can pass -- what they like -- - does the file look like a file?++-- | Run some sanity checks over a HupCommand, e.g. confirm+-- any files it refers to actually exist. sanity :: HupCommands -> IO HupCommands-sanity hc = do- let sanityTests = [fileSanity] -- TODO: add more sanity tests here <<+sanity !hc = do+ putStrLn "running sanity checks"+ let !sanityTests = [fileSanity] -- TODO: add more sanity tests here << -- compose them- composedSanityTests = foldl (>=>) return sanityTests- res <- runExceptT $ composedSanityTests hc+ !composedSanityTests = foldl (>=>) return sanityTests+ !res <- runExceptT $ composedSanityTests hc case res of Left err -> do print err exitFailure@@ -37,15 +43,16 @@ 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'+ -- ignore things without a file arg+ (isBuild -> True) -> return hc+ (isBoth -> True) -> return hc+ (isUp -> True) -> do let f = file hc+ absF <- liftIO $ makeAbsolute f+ unlessM ( liftIO $ doesFileExist absF ) $+ throwE $ "Cannot find a file '" <> f <> "'"+ let hc' = hc { file = absF }+ return hc'+ _ -> error "match error, shouldn't be possible"
+ src/Stack.hs view
@@ -0,0 +1,107 @@++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}++{- |++Abstract over some of stack's functionality.++-}++module Stack+where++import Control.Monad.IO.Class ( MonadIO(..) )+import Shelly.Lifted+import Data.Maybe+import Data.Text ( Text )+import qualified Data.Text as T+import Prelude hiding (FilePath)+import Control.Monad+import Data.Char (isSpace)+--import Control.Monad.Fail ( MonadFail )+--import Control.Monad.Trans.Maybe (runMaybeT)+++-- | just a convenience alias, short for @'MonadIO' m, 'MonadSh' m,+-- 'MonadShControl' m+type MonadShellish m = (MonadIO m, MonadSh m, MonadShControl m) ++-- | @haddockCanHyperlinkSrc@ tells you whether a version of+-- haddock is on the path that can do source hyperlinking.+-- +-- (implementation: versions of haddock that can't do source hyperlinking+-- return a non-zero status code if you pass "--hyperlinked-source".)+haddockCanHyperlinkSrc :: MonadShellish m => m Bool+haddockCanHyperlinkSrc = errExit False $ do+ silently $ run_ "haddock" ["--hyperlinked-source"]+ (==0) <$> lastExitCode++rstrip :: Text -> Text+rstrip = T.dropWhileEnd isSpace++-- | @onPath prog@ tells you whether the program+-- is on the path+onPath :: MonadSh f => FilePath -> f Bool+onPath prog =+ isJust <$> which prog++-- | check that stack is on path, or die.+stackIsOnPath :: MonadSh m => m ()+stackIsOnPath = + unlessM (onPath "stack") $ do+ echo "Couldn't find stack on path - do you need to install stack?"+ quietExit 1++-- | check that ghc can be executed, using stack, or die.+ghcIsOnPath :: MonadShellish m => m () +ghcIsOnPath = do+ errExit False $ run_ "stack" ["exec", "--", "which", "ghc"]+ exitCode <- lastExitCode + when (exitCode /= 0) $+ terror "Something is terribly wrong - couldn't get a path for ghc. exiting"+++-- | trim, convert, canonicalize a path given as Text+-- (e.g. from 'run').+extractPath :: MonadSh m => Text -> m FilePath+extractPath = canonicalize <=< (return . fromText . rstrip) ++-- | get the directory containing ghc and haddock+ghcDir :: MonadSh m => m FilePath+ghcDir =+ extractPath =<< run "stack" ["path", "--compiler-bin"]++-- | get the snapshot binaries directory, where programs+-- are installed+snapshotBinDir :: MonadShellish m => m FilePath+snapshotBinDir = + (</> "bin") <$> (extractPath =<< silently (run "stack" ["path", "--snapshot-install-root"]))+++-- | whether "cabal" is installed in the current snapshot.+cabalInstalled :: MonadShellish m => m Bool+cabalInstalled = do+ binDir <- snapshotBinDir + sub $ do+ setenv "PATH" (toTextIgnore binDir) + onPath "cabal"++-- | Install a @cabal@ executable, from the package @cabal-install@,+-- into the package snapshot.+installCabal :: MonadShellish m => m ()+installCabal = + verbosely $ run_ "stack" ["build", "--no-copy-bins", "cabal-install"]++-- | prepend haddock's directory to the path+addHaddockPath :: MonadSh m => m ()+addHaddockPath = do+ haddockDir <- extractPath =<< run "stack" ["path", "--compiler-bin"]+ prependToPath haddockDir++-- | prepend cabal's directory to the path+addCabalPath :: MonadShellish m => m ()+addCabalPath = + snapshotBinDir >>= prependToPath+
src/Upload.hs view
@@ -23,8 +23,11 @@ doUpload :: String -> Upload -> Maybe Auth -> IO (Either String String) doUpload server upl userAuth = do req <- buildRequest server upl userAuth- displayResponse `liftM` sendRequest req-+ maybeResp <- sendRequest req+ case maybeResp of+ Left exception -> return $ Left $ + "Request failed with a network exception: " ++ show exception+ Right resp -> return $ displayResponse resp -- | Turn a 'Response' into some sort of hopefully useful error message
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-7.14+resolver: lts-7.24 #resolver: lts-3.7 packages:
− test/Distribution/Hup/Parse/Test.hs
@@ -1,65 +0,0 @@---{- |--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
@@ -1,33 +0,0 @@---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
@@ -1,100 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--{- | Support for testing Distribution.Hup.Upload ---}--module Distribution.Hup.Upload.Test where--import qualified Data.ByteString.Lazy.Char8 as LBS -- pack-import qualified Network.HTTP.Client as HTTP.Client-import System.FilePath ( (</>) )-import System.IO.Temp (withSystemTempDirectory)-import Test.QuickCheck-import Test.QuickCheck.Monadic (run, assert, monadicIO)--import Distribution.Hup.Upload -import Distribution.Hup.Parse -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
@@ -1,176 +0,0 @@-{-# 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
@@ -1,70 +0,0 @@-{-# 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
@@ -1,7 +0,0 @@--import System.FilePath.Glob (glob)-import Test.DocTest (doctest)--main :: IO ()-main = glob "lib/**/*.hs" >>= doctest-
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}