Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
24 changes: 12 additions & 12 deletions exes/BuildClient.hs
Original file line number Diff line number Diff line change
Expand Up @@ -109,7 +109,7 @@ main = topHandler $ do
" hackage-build build [packages] [options]",
" hackage-build stats",
"Options:"]
mapM_ putStrLn $ strs
mapM_ putStrLn strs
putStrLn $ usageInfo usageHeader buildFlagDescrs
unless (null strs) exitFailure
Init uri auxUris -> initialise opts uri auxUris
Expand Down Expand Up @@ -339,18 +339,18 @@ infoStats verbosity mDetailedStats pkgIdsHaveDocs = do
-- NOTE: Expects the same number of columns in every row!
printTable :: [[String]] -> String
printTable xss = intercalate "\n"
. map (intercalate " ")
. map unwords
. map padCols
$ xss
where
colWidths :: [[Int]]
colWidths = map (map length) $ xss
colWidths = map (map length) xss

maxColWidths :: [Int]
maxColWidths = foldr1 (\xs ys -> map (uncurry max) (zip xs ys)) colWidths
maxColWidths = map maximum (transpose colWidths)

padCols :: [String] -> [String]
padCols cols = map (uncurry padTo) (zip maxColWidths cols)
padCols cols = zipWith padTo maxColWidths cols

padTo :: Int -> String -> String
padTo len str = str ++ replicate (len - length str) ' '
Expand Down Expand Up @@ -401,7 +401,7 @@ getDocumentationStats verbosity opts config pkgs = do
False -> return Nothing
mPackages <- fmap parseJsonStats <$> requestGET' (packagesUri False curGhcVersion)
mCandidates <- fmap parseJsonStats <$> requestGET' (packagesUri True curGhcVersion)
liftIO $ putStrLn $ show curGhcVersion
liftIO $ print curGhcVersion
case (mPackages, mCandidates) of
-- Download failure
(Nothing, _) -> fail $ "Could not download " ++ show (packagesUri False curGhcVersion)
Expand All @@ -426,9 +426,9 @@ getDocumentationStats verbosity opts config pkgs = do
hClose moutput
handler <- openFile dirloc ReadWriteMode
contents <- hGetContents handler
let res = read contents :: [(String, String)]
version' = fmap (\(_,b) -> b) $ find (\(a,_)-> a=="Project version") res
return $ version'
let res = read contents :: [(String, String)]
version' = lookup "Project version" res
return version'

getQry :: [PackageIdentifier] -> String
getQry [] = ""
Expand Down Expand Up @@ -576,7 +576,7 @@ processPkg verbosity opts config docInfo = do
coverageFile <- mapM (coveragePackage verbosity opts docInfo) hpcLoc

-- Modify test-outcome and rewrite report file.
mapM (setTestStatus mRpt buildReport) testOutcome
mapM_ (setTestStatus mRpt buildReport) testOutcome

case bo_dryRun opts of
True -> return ()
Expand Down Expand Up @@ -610,7 +610,7 @@ processPkg verbosity opts config docInfo = do
let buildReport' = fmap (unlines.setTestOutcome testOutcome) $ fmap lines buildReport
rewriteRpt mRpt buildReport'

coveragePackage :: Verbosity -> BuildOpts -> DocInfo -> FilePath -> IO (FilePath)
coveragePackage :: Verbosity -> BuildOpts -> DocInfo -> FilePath -> IO FilePath
coveragePackage verbosity opts docInfo loc = do
let pkgid = docInfoPackage docInfo
dir = takeDirectory loc
Expand Down Expand Up @@ -886,7 +886,7 @@ putBuildFiles config docInfo reportFile buildLogFile coverageFile installOk = do
(_, response) <- request Request {
rqURI = uri,
rqMethod = PUT,
rqHeaders = [Header HdrContentType ("application/json"),
rqHeaders = [Header HdrContentType "application/json",
Header HdrContentLength (show (BS.length body))],
rqBody = body
}
Expand Down
6 changes: 3 additions & 3 deletions exes/ImportClient.hs
Original file line number Diff line number Diff line change
Expand Up @@ -119,7 +119,7 @@ main = topHandler $ do
printHelp help = getProgName >>= putStr . help
printOptionsList = putStr . unlines
printErrors errs = do
putStr (concat (intersperse "\n" errs))
putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printVersion = putStrLn $ "hackage-import " ++ display Paths.version

Expand Down Expand Up @@ -408,7 +408,7 @@ importIndex jobs indexFile baseURI = do
=<< LBS.readFile indexFile

pkgs' <- evaluate (sortBy (comparing fst) pkgs)
info $ "Uploading..."
info "Uploading..."

concForM_ jobs pkgs' $ \tasks ->
httpSession $ do
Expand Down Expand Up @@ -802,7 +802,7 @@ downloadCountCommand =
where
name = "downloads"
shortDesc = "Import download counts"
longDesc = Just $ \_ -> unlines $ [
longDesc = Just $ \_ -> unlines [
"Replace the on-disk download statistics with the download statistics"
, "extracted from Apache log files (in .gz format)"
]
Expand Down
12 changes: 5 additions & 7 deletions exes/Main.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,3 @@
{-# LANGUAGE PatternGuards #-}

module Main where

import qualified Distribution.Server as Server
Expand Down Expand Up @@ -44,8 +42,8 @@ import Data.Maybe
( isNothing )
import Data.List
( intercalate, isInfixOf )
import Data.Traversable
( forM )
import Data.Foldable
( forM_ )
import Data.Version
( showVersion )
import Control.Monad
Expand Down Expand Up @@ -377,7 +375,7 @@ runAction opts = do
fail $ "Sorry, the server assumes it will be served (or proxied) "
++ " via http or https, so cannot use uri scheme " ++ uriScheme uri
| isNothing (uriAuthority uri) ->
fail $ "The base-uri has to include the full host name"
fail "The base-uri has to include the full host name"
| uriPath uri `notElem` ["", "/"] ->
fail $ "Sorry, the server assumes the base-uri to be at the root of "
++ " the domain, so cannot use " ++ uriPath uri
Expand Down Expand Up @@ -689,7 +687,7 @@ testBackupCommand =
flagTestBackupScrubbed (\v flags -> flags { flagTestBackupScrubbed = v })
(noArg (Flag True))
, option [] ["features"]
("Only test the specified features")
"Only test the specified features"
flagTestBackupFeatures (\v flags -> flags { flagTestBackupFeatures = v })
(reqArgFlag "FEATURES")
]
Expand Down Expand Up @@ -920,7 +918,7 @@ withServer config doTemp = bracket initialise shutdown
loginfo verbosity "Initializing happstack-state..."
server <- Server.initialise config
loginfo verbosity "Server data loaded into memory"
void $ forM mtemp $ \temp -> do
forM_ mtemp $ \temp -> do
loginfo verbosity "Tearing down temp server"
Server.tearDownTemp temp
return server
Expand Down
2 changes: 1 addition & 1 deletion exes/MirrorClient.hs
Original file line number Diff line number Diff line change
Expand Up @@ -126,7 +126,7 @@ mirrorOnce verbosity opts
ignoreCount = length pkgsToMirror - mirrorCount

if mirrorCount == 0
then liftIO $ notice verbosity $ "No packages to mirror"
then liftIO $ notice verbosity "No packages to mirror"
else do
liftIO $ notice verbosity $
show mirrorCount ++ " packages to mirror."
Expand Down
2 changes: 1 addition & 1 deletion src/Distribution/Client.hs
Original file line number Diff line number Diff line change
Expand Up @@ -100,7 +100,7 @@ data PkgIndexInfo = PkgIndexInfo
downloadIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]
downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri
| otherwise = downloadNewIndex uri
where


isOldHackageURI :: URI -> Bool
isOldHackageURI uri
Expand Down
4 changes: 2 additions & 2 deletions src/Distribution/Client/Mirror/Repo/Secure.hs
Original file line number Diff line number Diff line change
Expand Up @@ -187,12 +187,12 @@ finalizeLocalMirror' cache repoRoot = (`runContT` return) $ do
let (dir, template) = splitFileName dst
bracket (openBinaryTempFileWithDefaultPermissions dir template)
(\(temp, h) -> ignoreIOErrors (hClose h >> removeFile temp)) $
(\(temp, h) -> do
\(temp, h) -> do
BS.L.hPut h =<< BS.L.readFile src
hClose h
a <- callback ()
renameFile temp dst
return a)
return a

ignoreIOErrors :: IO () -> IO ()
ignoreIOErrors = handle $ \(_ :: IOException) -> return ()
Expand Down
4 changes: 2 additions & 2 deletions src/Distribution/Client/Mirror/State.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ module Distribution.Client.Mirror.State (
-- stdlib
import Control.Exception
import Control.Monad
import Data.Maybe (catMaybes)
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import Network.URI
import System.Directory
Expand Down Expand Up @@ -115,7 +115,7 @@ readPkgProblemFile file = do
exists <- doesFileExist file
if exists
then evaluate . Set.fromList
. catMaybes . map simpleParse . lines
. mapMaybe simpleParse . lines
=<< readFile file
else return Set.empty

Expand Down
8 changes: 4 additions & 4 deletions src/Distribution/Server.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module Distribution.Server (
-- * Server control
Server(..),
Expand Down Expand Up @@ -287,7 +287,7 @@ initState server (admin, pass) = do
Nothing -> fail "Couldn't parse admin name (should be alphanumeric)"
case muid of
Right uid -> Group.addUserToGroup adminGroup uid
Left Users.ErrUserNameClash -> fail $ "Inconceivable!! failed to create admin user"
Left Users.ErrUserNameClash -> fail "Inconceivable!! failed to create admin user"

-- The top-level server part.
-- It collects resources from Distribution.Server.Features, collects
Expand Down Expand Up @@ -341,7 +341,7 @@ setUpTemp sconf secs = do
-- cost to it
threadDelay $ secs*1000000
-- could likewise specify a mirror to redirect to for tarballs, and 503 for everything else
runServer listenOn $ (resp 503 $ setHeader "Content-Type" "text/html" $ toResponse html503)
runServer listenOn $ resp 503 $ setHeader "Content-Type" "text/html" $ toResponse html503
return (TempServer tid)
where listenOn = confListenOn sconf

Expand All @@ -362,4 +362,4 @@ tearDownTemp :: TempServer -> IO ()
tearDownTemp (TempServer tid) = do
killThread tid
-- give the server enough time to release the bind
threadDelay $ 1000000
threadDelay 1000000
4 changes: 2 additions & 2 deletions src/Distribution/Server/Features/AdminLog.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ import Distribution.Server.Features.Users

import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable
import Data.Maybe(catMaybes)
import Data.Maybe(mapMaybe)
import Control.Monad.Reader
import qualified Control.Monad.State as State
import Data.Time (UTCTime)
Expand Down Expand Up @@ -161,7 +161,7 @@ restoreAdminLogBackup =

importLogs :: AdminLog -> BS.ByteString -> AdminLog
importLogs (AdminLog ls) =
AdminLog . (++ls) . catMaybes . map fromRecord . lines . unpackUTF8
AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8
where
fromRecord :: String -> Maybe (UTCTime,UserId,AdminAction,BS.ByteString)
fromRecord = readMaybe
Expand Down
2 changes: 1 addition & 1 deletion src/Distribution/Server/Features/Browse.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE BlockArguments, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE BlockArguments, NamedFieldPuns #-}
module Distribution.Server.Features.Browse (initBrowseFeature, PaginationConfig(..), StartIndex(..), NumElems(..), paginate) where

import Control.Arrow (left)
Expand Down
5 changes: 2 additions & 3 deletions src/Distribution/Server/Features/Browse/ApplyFilter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -28,8 +28,7 @@ applyFilter now isSearch coreResource userResource tagsResource DistroFeature{qu
packages <- filterM filterForItem items
pure $
map packageIndexInfoToValue $
sort isSearch (boSort browseOptions) $
packages
sort isSearch (boSort browseOptions) packages
where
packageIndexInfoToValue :: PackageItem -> Value
packageIndexInfoToValue PackageItem{..} =
Expand Down Expand Up @@ -85,7 +84,7 @@ applyFilter now isSearch coreResource userResource tagsResource DistroFeature{qu

filterForItem :: PackageItem -> IO Bool
filterForItem item =
all id <$> traverse (includeItem item) filtersWithDefaults
and <$> traverse (includeItem item) filtersWithDefaults

sort :: IsSearch -> Sort -> [PackageItem] -> [PackageItem]
sort isSearch Sort {sortColumn, sortDirection} =
Expand Down
4 changes: 2 additions & 2 deletions src/Distribution/Server/Features/BuildReports/State.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,
FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
TypeOperators, TypeSynonymInstances #-}
TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Distribution.Server.Features.BuildReports.State where

Expand Down Expand Up @@ -67,7 +67,7 @@ setFailStatus pkgid status = do
let reports = BuildReports.setFailStatus pkgid status buildReports
State.put reports

resetFailCount :: PackageId -> Update BuildReports (Bool)
resetFailCount :: PackageId -> Update BuildReports Bool
resetFailCount pkgid = do
buildReports <- State.get
case BuildReports.resetFailCount pkgid buildReports of
Expand Down
6 changes: 3 additions & 3 deletions src/Distribution/Server/Features/Core.hs
Original file line number Diff line number Diff line change
Expand Up @@ -502,7 +502,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
-- Queries
--
queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo)
queryGetPackageIndex = return . packageIndex =<< queryState packagesState GetPackagesState
queryGetPackageIndex = packageIndex <$> queryState packagesState GetPackagesState

queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo
queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball
Expand Down Expand Up @@ -753,11 +753,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
deauth _ = do
return $ (toResponse ("<script>window.location='/'</script>"::String)) {
rsCode = 401
, rsHeaders = mkHeaders ([("Content-Type", "text/html")])
, rsHeaders = mkHeaders [("Content-Type", "text/html")]
}

packageExists, packageIdExists :: (Package pkg, Package pkg') => PackageIndex pkg -> pkg' -> Bool
-- | Whether a package exists in the given package index.
packageExists pkgs pkg = not . null $ PackageIndex.lookupPackageName pkgs (packageName pkg)
-- | Whether a particular package version exists in the given package index.
packageIdExists pkgs pkg = maybe False (const True) $ PackageIndex.lookupPackageId pkgs (packageId pkg)
packageIdExists pkgs pkg = isJust $ PackageIndex.lookupPackageId pkgs (packageId pkg)
2 changes: 1 addition & 1 deletion src/Distribution/Server/Features/Core/Backup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -292,7 +292,7 @@ forceLast :: BS.ByteString -> BS.ByteString
forceLast = BS.fromChunks . forceLastBlock . BS.toChunks
where
forceLastBlock [] = []
forceLastBlock (c:[]) = c : []
forceLastBlock [c] = [c]
forceLastBlock (c:cs) = c : forceLastBlock cs

--------------------------------------------------------------------------------
Expand Down
6 changes: 3 additions & 3 deletions src/Distribution/Server/Features/Distro.hs
Original file line number Diff line number Diff line change
Expand Up @@ -115,10 +115,10 @@ distroFeature UserFeature{..}

textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros)
textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do
let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) $ pkgs
let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs
return $ toResponse (unlines $ ("Packages for " ++ display dname):pkglines)
csvDistroPackageList dpath = withDistroPath dpath $ \_dname pkgs -> do
return $ toResponse $ packageListToCSV $ pkgs
return $ toResponse $ packageListToCSV pkgs
textDistroPkg dpath = withDistroPackagePath dpath $ \_ _ info -> return . toResponse $ show info

-- result: see-other uri, or an error: not authenticated or not found (todo)
Expand All @@ -127,7 +127,7 @@ distroFeature UserFeature{..}
guardAuthorised_ [InGroup adminGroup] --TODO: use the per-distro maintainer groups
-- should also check for existence here of distro here
void $ updateState distrosState $ RemoveDistro distro
seeOther ("/distros/") (toResponse ())
seeOther "/distros/" (toResponse ())

-- result: ok response or not-found error
distroPackageDelete dpath =
Expand Down
7 changes: 3 additions & 4 deletions src/Distribution/Server/Features/Documentation.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ import Distribution.Server.Features.Users
import Distribution.Server.Features.Core
import Distribution.Server.Features.TarIndexCache
import Distribution.Server.Features.BuildReports
import Distribution.Version ( Version )
import Distribution.Version (Version, nullVersion)

import Distribution.Server.Framework.BackupRestore
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
Expand All @@ -29,7 +29,6 @@ import qualified Codec.Archive.Tar.Check as Tar

import Distribution.Text
import Distribution.Package
import Distribution.Version (nullVersion)
import qualified Distribution.Parsec as P

import qualified Data.ByteString.Char8 as C
Expand Down Expand Up @@ -113,7 +112,7 @@ documentationStateComponent name stateDir = do
}
where
dumpBackup doc =
let exportFunc (pkgid, blob) = BackupBlob ([display pkgid, "documentation.tar"]) blob
let exportFunc (pkgid, blob) = BackupBlob [display pkgid, "documentation.tar"] blob
in map exportFunc . Map.toList $ documentation doc

updateDocumentation :: Documentation -> RestoreBackup Documentation
Expand Down Expand Up @@ -227,7 +226,7 @@ documentationFeature name
parseVersion' (Just k) = P.simpleParsec k

parsePkgs :: String -> [PackageIdentifier]
parsePkgs pkgsStr = map fromJust $ filter isJust $ map (P.simpleParsec . C.unpack) $ C.split ',' (C.pack pkgsStr)
parsePkgs pkgsStr = mapMaybe (P.simpleParsec . C.unpack) (C.split ',' (C.pack pkgsStr))

isSelectedPackage pkgid pkgid'@(PackageIdentifier _ v)
| nullVersion == v =
Expand Down
Loading