Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Propose fuzzy-matched versions #557

Merged
merged 2 commits into from
Jul 13, 2015
Merged

Propose fuzzy-matched versions #557

Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
dff8c75
Propose fuzzy-matched versions
k-bx Jul 10, 2015
d27aa94
Bring back "fix amp" comment
k-bx Jul 10, 2015
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
156 changes: 93 additions & 63 deletions src/Stack/Fetch.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,57 +22,59 @@ module Stack.Fetch
, withCabalLoader
) where

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Check as Tar
import Codec.Compression.GZip (decompress)
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Check as Tar
import Codec.Compression.GZip (decompress)
import Control.Applicative
import Control.Concurrent.Async (Concurrently (..))
import Control.Concurrent.MVar.Lifted (newMVar, modifyMVar)
import Control.Concurrent.STM (TVar, atomically, modifyTVar,
newTVarIO, readTVar,
readTVarIO, writeTVar)
import Control.Exception (assert)
import Control.Monad (liftM, when, join, unless, void)
import Control.Concurrent.Async (Concurrently (..))
import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar)
import Control.Concurrent.STM (TVar, atomically, modifyTVar,
newTVarIO, readTVar,
readTVarIO, writeTVar)
import Control.Exception (assert)
import Control.Monad (join, liftM, unless, void,
when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (asks)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader (asks)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Trans.Control
import Crypto.Hash (SHA512(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
import Data.Function (fix)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Typeable (Typeable)
import Data.Word (Word64)
import Crypto.Hash (SHA512 (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
import Data.Function (fix)
import Data.IORef (newIORef, readIORef,
writeIORef)
import Data.List (intercalate, intersperse)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Typeable (Typeable)
import Data.Word (Word64)
import Network.HTTP.Download
import Path
import Prelude -- Fix AMP warning
import Prelude
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This comment shouldn't get lost, as someone may then accidentally remove the import.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@snoyberg sorry, it was lost because of stylish-haskell, will bring it back

import Stack.GhcPkg
import Stack.PackageIndex
import Stack.Types
import System.Directory (canonicalizePath,
createDirectoryIfMissing,
doesDirectoryExist,
renameDirectory)
import System.FilePath ((<.>))
import qualified System.FilePath as FP
import System.IO (IOMode (ReadMode),
SeekMode (AbsoluteSeek),
hSeek, withBinaryFile)
import System.Directory (canonicalizePath,
createDirectoryIfMissing,
doesDirectoryExist,
renameDirectory)
import System.FilePath ((<.>))
import qualified System.FilePath as FP
import System.IO (IOMode (ReadMode),
SeekMode (AbsoluteSeek), hSeek,
withBinaryFile)

data FetchException
= Couldn'tReadIndexTarball FilePath Tar.FormatError
Expand Down Expand Up @@ -170,8 +172,8 @@ unpackPackageIdents menv unpackDir mdistDir idents = do
return $ alreadyUnpacked <> nowUnpacked

data ResolvedPackage = ResolvedPackage
{ rpCache :: !PackageCache
, rpIndex :: !PackageIndex
{ rpCache :: !PackageCache
, rpIndex :: !PackageIndex
}

-- | Resolve a set of package names and identifiers into @FetchPackage@ values.
Expand Down Expand Up @@ -274,38 +276,66 @@ withCabalLoader menv inner = do
runInBase <- liftBaseWith $ \run -> return (void . run)

-- TODO in the future, keep all of the necessary @Handle@s open
let doLookup ident = do
eres <- doLookup' ident
let doLookup :: PackageIdentifier
-> IO ByteString
doLookup ident = do
cachesCurr <- liftIO $ readIORef icaches
eres <- lookupPackageIdentifierExact ident env cachesCurr
case eres of
Right bs -> return bs
Just bs -> return bs
-- Update the cache and try again
Left e -> join $ modifyMVar updateRef $ \toUpdate ->
if toUpdate
then do
Nothing -> do
let fuzzy = fuzzyLookupCandidates ident cachesCurr
fuzzyCandidatesText = case fuzzy of
Nothing -> ""
Just cs -> "Possible candidates: "
<> commaSeparatedIdents cs
<> ". "
join $ modifyMVar updateRef $ \toUpdate ->
if toUpdate then do
runInBase $ do
$logInfo $ T.concat
[ "Didn't see "
, T.pack $ packageIdentifierString ident
, " in your package indices, updating and trying again"
, " in your package indices. "
, T.pack fuzzyCandidatesText
, "Updating and trying again."
]
updateAllIndices menv
caches <- getPackageCaches menv
liftIO $ writeIORef icaches caches
return (False, doLookup ident)
else return (toUpdate, throwM e)

doLookup' ident = do
caches <- liftIO $ readIORef icaches
case Map.lookup ident caches of
Nothing ->
return $ Left $ UnknownPackageIdentifiers $ Set.singleton ident
Just (index, cache) -> do
[bs] <- flip runReaderT env
$ withCabalFiles (indexName index) [(ident, cache, ())]
$ \_ _ bs -> return bs
return $ Right bs

else return (toUpdate, throwM (unknownIdent ident))
inner doLookup
where
unknownIdent = UnknownPackageIdentifiers . Set.singleton
commaSeparatedIdents = F.fold . intersperse ", " . map packageIdentifierString

type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache)

lookupPackageIdentifierExact :: HasConfig env
=> PackageIdentifier -> env -> PackageCaches
-> IO (Maybe ByteString)
lookupPackageIdentifierExact ident env caches = do
case Map.lookup ident caches of
Nothing -> return Nothing
Just (index, cache) -> do
[bs] <- flip runReaderT env
$ withCabalFiles (indexName index) [(ident, cache, ())]
$ \_ _ bs -> return bs
return $ Just bs

-- TODO: use 'Maybe (NonEmpty PackageIdentifier)' return-type
fuzzyLookupCandidates :: PackageIdentifier -> PackageCaches
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It would probably be more efficient to convert PackageCaches into a Map PackageName (Set Version) to avoid traversing the entire collection for every mismatched name.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@snoyberg yeah, I decided to not go for efficiency, as this seems like a rare piece of functionality. But since you mentioned it – I have no problem making it efficient then.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@snoyberg I updated function to be better in terms of alg complexity. It now uses Map.splitLookup to do a logN-split, filtering smaller elements. It then filters bigger elements by doing takeWhile (takes only satisfying head).

Thus, I think I don't understand your comment in full. Since we're only running this algorithm for one package (I tested, if two packages didn't match we still fail and error only for the first one), the map-reconstruction for better version-matching wouldn't make a lot of sense. Might be that it would make sense in future, when we show errors for many packages at once.

-> Maybe [PackageIdentifier]
fuzzyLookupCandidates (PackageIdentifier name ver) caches =
if null sameMajor then Nothing else Just (map fst sameMajor)
where
sameIdentCaches = filter (\(PackageIdentifier n _, _) -> name == n)
(Map.toList caches)
sameMajor = filter (\(PackageIdentifier _ v, _) ->
getMajorVersion ver == getMajorVersion v)
sameIdentCaches

-- | Figure out where to fetch from.
getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)
Expand Down