diff --git a/Application.hs b/Application.hs index a9ab830..5b79c80 100644 --- a/Application.hs +++ b/Application.hs @@ -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 diff --git a/Data/BlobStore.hs b/Data/BlobStore.hs index 51d8516..a3c440c 100644 --- a/Data/BlobStore.hs +++ b/Data/BlobStore.hs @@ -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! diff --git a/Data/Hackage.hs b/Data/Hackage.hs index 65040c6..bbe47b3 100644 --- a/Data/Hackage.hs +++ b/Data/Hackage.hs @@ -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) diff --git a/Data/Hackage/Views.hs b/Data/Hackage/Views.hs index 29b08f0..e879145 100644 --- a/Data/Hackage/Views.hs +++ b/Data/Hackage/Views.hs @@ -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 diff --git a/Echo.hs b/Echo.hs index b12a3a0..eff2102 100644 --- a/Echo.hs +++ b/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" "" diff --git a/Foundation.hs b/Foundation.hs index 3255d08..dd25c76 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -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 diff --git a/Handler/HackageViewSdist.hs b/Handler/HackageViewSdist.hs index ede5235..610fe67 100644 --- a/Handler/HackageViewSdist.hs +++ b/Handler/HackageViewSdist.hs @@ -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 diff --git a/Handler/Profile.hs b/Handler/Profile.hs index 94e726c..75ffc9c 100644 --- a/Handler/Profile.hs +++ b/Handler/Profile.hs @@ -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) diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index 8689db2..8bfcc8b 100644 --- a/Handler/UploadStackage.hs +++ b/Handler/UploadStackage.hs @@ -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 diff --git a/Import.hs b/Import.hs index bd3f557..d2deca4 100644 --- a/Import.hs +++ b/Import.hs @@ -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 diff --git a/stackage-server.cabal b/stackage-server.cabal index 83bc49b..4128204 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -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 diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index 5bc929b..1b5bdff 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -4,7 +4,7 @@ of complete package sets. Think “stable Hackage”.

Recommended Snapshots