mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
Fix all warnings
This commit is contained in:
parent
e2ca5dcfd6
commit
85939d1631
@ -72,8 +72,8 @@ makeApplication echo@True conf = do
|
||||
}
|
||||
Echo.clear
|
||||
return (logWare (defaultMiddlewaresNoLogging app),logFunc)
|
||||
where logFunc (Loc filename _pkg _mod (line,_) _) source level str =
|
||||
Echo.write (filename,line) (show source ++ ": " ++ show level ++ ": " ++ toStr str)
|
||||
where logFunc (Loc filename' _pkg _mod (line,_) _) source level str =
|
||||
Echo.write (filename',line) (show source ++ ": " ++ show level ++ ": " ++ toStr str)
|
||||
toStr = unpack . decodeUtf8 . fromLogStr
|
||||
makeApplication echo@False conf = do
|
||||
foundation <- makeFoundation echo conf
|
||||
|
||||
@ -91,6 +91,7 @@ fileStore root = BlobStore
|
||||
, storeExists' = liftIO . F.isFile . toFP root
|
||||
}
|
||||
|
||||
toFP :: ToPath a => FilePath -> a -> FilePath
|
||||
toFP root key = foldl' (\x y -> x </> fpFromText y) root (toPath key)
|
||||
|
||||
-- | Note: Only use with data which will never be modified!
|
||||
|
||||
@ -17,7 +17,6 @@ import qualified Codec.Archive.Tar as Tar
|
||||
import Control.Monad.Reader (MonadReader, ask)
|
||||
import qualified Data.Text as T
|
||||
import Data.Conduit.Zlib (ungzip, gzip)
|
||||
import Text.XML.Cursor (($//), (&/), content, fromDocument, element, followingSibling)
|
||||
import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
|
||||
import System.IO (IOMode (ReadMode), openBinaryFile)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
@ -25,9 +24,9 @@ import Model (Uploaded (Uploaded))
|
||||
import Filesystem (createTree)
|
||||
import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
|
||||
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
|
||||
import Distribution.PackageDescription (GenericPackageDescription, PackageDescription, packageDescription)
|
||||
import Distribution.PackageDescription (GenericPackageDescription)
|
||||
import Control.Exception (throw)
|
||||
import Control.Monad.State.Strict (modify, put, get, execStateT, MonadState)
|
||||
import Control.Monad.State.Strict (put, get, execStateT, MonadState)
|
||||
|
||||
sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
|
||||
sinkUploadHistory =
|
||||
@ -77,6 +76,9 @@ loadCabalFiles uploadHistory0 = flip execStateT (UploadState uploadHistory0 [])
|
||||
setUploadDate name version
|
||||
_ -> return ()
|
||||
|
||||
tarSource :: (Exception e, MonadThrow m)
|
||||
=> Tar.Entries e
|
||||
-> Producer m Tar.Entry
|
||||
tarSource Tar.Done = return ()
|
||||
tarSource (Tar.Fail e) = throwM e
|
||||
tarSource (Tar.Next e es) = yield e >> tarSource es
|
||||
@ -123,11 +125,6 @@ setUploadDate name version = do
|
||||
, "/upload-time"
|
||||
]
|
||||
|
||||
hasContent t c =
|
||||
if T.concat (c $// content) == t
|
||||
then [c]
|
||||
else []
|
||||
|
||||
parseFilePath :: String -> Maybe (PackageName, Version)
|
||||
parseFilePath s =
|
||||
case filter (not . null) $ T.split (== '/') $ pack s of
|
||||
@ -262,16 +259,16 @@ createView viewName modifyCabal src sink = withSystemTempDirectory "createview"
|
||||
key = HackageViewCabal viewName name version
|
||||
mprev <- storeRead key
|
||||
case mprev of
|
||||
Just src -> do
|
||||
Just src' -> do
|
||||
liftIO $ createTree $ directory fp
|
||||
src $$ sinkFile fp
|
||||
src' $$ sinkFile fp
|
||||
return $ asSet $ singletonSet relfp
|
||||
Nothing -> do
|
||||
msrc <- storeRead $ HackageCabal name version
|
||||
case msrc of
|
||||
Nothing -> return mempty
|
||||
Just src -> do
|
||||
orig <- src $$ sinkLazy
|
||||
Just src' -> do
|
||||
orig <- src' $$ sinkLazy
|
||||
new <-
|
||||
case parsePackageDescription $ unpack $ decodeUtf8 orig of
|
||||
ParseOk _ gpd -> do
|
||||
@ -299,6 +296,10 @@ sourceHistory =
|
||||
go' (version, time) = yield $ Uploaded name version time
|
||||
|
||||
-- FIXME put in conduit-combinators
|
||||
parMapMC :: (MonadIO m, MonadBaseControl IO m)
|
||||
=> Int
|
||||
-> (i -> m o)
|
||||
-> Conduit i m o
|
||||
parMapMC _ = mapMC
|
||||
{- FIXME
|
||||
parMapMC :: (MonadIO m, MonadBaseControl IO m)
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
|
||||
module Data.Hackage.Views where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -8,6 +9,7 @@ import Distribution.Text (simpleParse)
|
||||
import Data.NonNull (fromNullable) -- FIXME expose from ClassyPrelude
|
||||
import Data.Hackage (UploadHistory)
|
||||
import Data.Time (addUTCTime)
|
||||
import qualified Types
|
||||
|
||||
viewUnchanged :: Monad m
|
||||
=> packageName -> version -> time
|
||||
@ -62,6 +64,10 @@ viewNoBounds _ _ _ =
|
||||
where
|
||||
go (Dependency name _range) = return $ Dependency name anyVersion
|
||||
|
||||
getAvailable :: Types.PackageName
|
||||
-> UTCTime
|
||||
-> HashMap Types.PackageName (HashMap Types.Version UTCTime)
|
||||
-> [Types.Version]
|
||||
getAvailable name maxUploaded =
|
||||
map fst . filter ((<= maxUploaded) . snd) . mapToList . fromMaybe mempty . lookup name
|
||||
|
||||
@ -71,6 +77,7 @@ getAvailable name maxUploaded =
|
||||
-- technically it "wasn't available" yet.
|
||||
--
|
||||
-- The actual value we should use is up for debate. I'm starting with 24 hours.
|
||||
addFuzz :: UTCTime -> UTCTime
|
||||
addFuzz = addUTCTime (60 * 60 * 24)
|
||||
|
||||
viewPVP :: Monad m
|
||||
|
||||
1
Echo.hs
1
Echo.hs
@ -43,4 +43,5 @@ write (file,line) it =
|
||||
loc = file ++ ":" ++ show line
|
||||
fmt = formatTime defaultTimeLocale "%T%Q"
|
||||
|
||||
clear :: IO ()
|
||||
clear = writeFile "/tmp/echo" ""
|
||||
|
||||
@ -3,7 +3,6 @@ module Foundation where
|
||||
import ClassyPrelude.Yesod
|
||||
import Data.BlobStore
|
||||
import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug)
|
||||
import Data.Text (Text)
|
||||
import qualified Database.Persist
|
||||
import Model
|
||||
import qualified Settings
|
||||
@ -78,7 +77,6 @@ instance Yesod App where
|
||||
"config/client_session_key.aes"
|
||||
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
mmsg <- getMessage
|
||||
muser <- maybeAuth
|
||||
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.HackageViewSdist where
|
||||
|
||||
import Import
|
||||
import Data.Hackage
|
||||
import Data.Conduit.Lazy (MonadActive (..))
|
||||
|
||||
getHackageViewSdistR :: HackageView -> PackageNameVersion -> Handler TypedContent
|
||||
getHackageViewSdistR viewName (PackageNameVersion name version) = do
|
||||
@ -18,6 +17,3 @@ getHackageViewSdistR viewName (PackageNameVersion name version) = do
|
||||
, ".tar.gz"
|
||||
]
|
||||
respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
|
||||
|
||||
instance MonadActive m => MonadActive (HandlerT site m) where -- FIXME upstream
|
||||
monadActive = lift monadActive
|
||||
|
||||
@ -4,7 +4,7 @@ import Import
|
||||
import Data.Slug (slugField)
|
||||
|
||||
userForm :: User -> Form User
|
||||
userForm user = renderBootstrap $ User
|
||||
userForm user = renderBootstrap2 $ User
|
||||
<$> areq slugField "User handle"
|
||||
{ fsTooltip = Just "Used for URLs"
|
||||
} (Just $ userHandle user)
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Handler.UploadStackage where
|
||||
|
||||
import Import hiding (catch, get)
|
||||
import Import hiding (catch, get, update)
|
||||
import System.IO.Temp (withSystemTempFile, withSystemTempDirectory, openBinaryTempFile)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
import Crypto.Hash (Digest, SHA1)
|
||||
@ -14,7 +14,7 @@ import Data.BlobStore
|
||||
import Filesystem (createTree)
|
||||
import Control.Monad.State.Strict (execStateT, get, put)
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import Control.Monad.Trans.Resource (unprotect, allocate)
|
||||
import Control.Monad.Trans.Resource (allocate)
|
||||
import System.Directory (removeFile, getTemporaryDirectory)
|
||||
import System.Process (runProcess, waitForProcess)
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
@ -50,7 +50,7 @@ putUploadStackageR = do
|
||||
malias <- lookupPostParam "alias"
|
||||
|
||||
tempDir <- liftIO getTemporaryDirectory
|
||||
(releaseKey, (fp, handleOut)) <- allocate
|
||||
(_releaseKey, (fp, handleOut)) <- allocate
|
||||
(openBinaryTempFile tempDir "upload-stackage.")
|
||||
(\(fp, h) -> hClose h `finally` removeFile fp)
|
||||
digest <- fileSource file
|
||||
@ -102,18 +102,18 @@ putUploadStackageR = do
|
||||
, lsFiles = mempty
|
||||
, lsIdent = ident
|
||||
}
|
||||
withSystemTempFile "newindex" $ \fp h -> do
|
||||
withSystemTempFile "newindex" $ \fp' h -> do
|
||||
ec <- liftIO $ do
|
||||
hClose h
|
||||
let args = "cfz"
|
||||
: fp
|
||||
: fp'
|
||||
: map fpToString (setToList files)
|
||||
ph <- runProcess "tar" args (Just dir) Nothing Nothing Nothing Nothing
|
||||
waitForProcess ph
|
||||
if ec == ExitSuccess
|
||||
then do
|
||||
sourceFile (fpFromString fp) $$ storeWrite (CabalIndex ident)
|
||||
runDB $ insert stackage
|
||||
sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
|
||||
runDB $ insert_ stackage
|
||||
|
||||
setAlias
|
||||
|
||||
@ -130,7 +130,7 @@ putUploadStackageR = do
|
||||
loop update entries
|
||||
|
||||
addEntry update entry = do
|
||||
update $ "Processing file: " ++ pack (Tar.entryPath entry)
|
||||
_ <- update $ "Processing file: " ++ pack (Tar.entryPath entry)
|
||||
case Tar.entryContent entry of
|
||||
Tar.NormalFile lbs _ ->
|
||||
case filename $ fpFromString $ Tar.entryPath entry of
|
||||
@ -150,7 +150,7 @@ putUploadStackageR = do
|
||||
case parseName line of
|
||||
Just (name, version) -> do
|
||||
$logDebug $ "hackage: " ++ tshow (name, version)
|
||||
update $ concat
|
||||
_ <- update $ concat
|
||||
[ "Adding Hackage package: "
|
||||
, toPathPiece name
|
||||
, "-"
|
||||
@ -167,7 +167,7 @@ putUploadStackageR = do
|
||||
, Just (name, version) <- parseName (fpToText base) -> do
|
||||
ident <- lsIdent <$> get
|
||||
sourceLazy lbs $$ storeWrite (CustomSdist ident name version)
|
||||
update $ concat
|
||||
_ <- update $ concat
|
||||
[ "Extracting cabal file for custom tarball: "
|
||||
, toPathPiece name
|
||||
, "-"
|
||||
@ -211,6 +211,11 @@ data LoopState = LoopState
|
||||
, lsIdent :: !PackageSetIdent
|
||||
}
|
||||
|
||||
extractCabal :: (MonadLogger m, MonadThrow m)
|
||||
=> LByteString
|
||||
-> PackageName -- ^ name
|
||||
-> Version -- ^ version
|
||||
-> m LByteString
|
||||
extractCabal lbs name version =
|
||||
loop $ Tar.read $ GZip.decompress lbs
|
||||
where
|
||||
@ -219,7 +224,7 @@ extractCabal lbs name version =
|
||||
loop (Tar.Next e es) = do
|
||||
$logDebug $ tshow (Tar.entryPath e, fp)
|
||||
case Tar.entryContent e of
|
||||
Tar.NormalFile lbs _ | Tar.entryPath e == fp -> return lbs
|
||||
Tar.NormalFile lbs' _ | Tar.entryPath e == fp -> return lbs'
|
||||
_ -> loop es
|
||||
|
||||
fp = unpack $ concat
|
||||
|
||||
@ -3,7 +3,6 @@ module Import
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod as Import
|
||||
import Data.Text as Import (Text)
|
||||
import Foundation as Import
|
||||
import Model as Import
|
||||
import Settings as Import
|
||||
|
||||
@ -72,10 +72,10 @@ library
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2.12 && < 1.3
|
||||
, yesod-core >= 1.2.19 && < 1.3
|
||||
, yesod-auth >= 1.3 && < 1.4
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
, yesod-form >= 1.3 && < 1.4
|
||||
, yesod-form >= 1.3.14 && < 1.4
|
||||
, bytestring >= 0.9 && < 0.11
|
||||
, text >= 0.11 && < 2.0
|
||||
, persistent >= 1.3.1 && < 1.4
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
of complete package sets. Think “stable Hackage”.
|
||||
<h2 .recommended-snapshots>Recommended Snapshots
|
||||
<ul .snapshots>
|
||||
$forall (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle) <- stackages
|
||||
$forall (E.Value ident, E.Value title, E.Value _uploaded, E.Value _display, E.Value _handle) <- stackages
|
||||
<li>
|
||||
<a href=@{StackageHomeR ident}>
|
||||
#{title}
|
||||
|
||||
@ -17,7 +17,7 @@ main = do
|
||||
conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing)
|
||||
{ csParseExtra = parseExtra
|
||||
}
|
||||
foundation <- makeFoundation conf
|
||||
foundation <- makeFoundation False conf
|
||||
hspec $ do
|
||||
Data.SlugSpec.spec
|
||||
yesodSpec foundation $ do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user