diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for staversion +## 0.1.1.0 -- 2016-11-03 + +* Now staversion fetches build plan YAML files over network, if necessary. +* Now staversion disambiguates partial resolvers (e.g. "lts-2") into exact resolvers (e.g. "lts-2.22"). +* New option `--no-network`, which forbids staversion to access network. + ## 0.1.0.0 -- 2016-10-16 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,17 +24,15 @@ conduit ==1.2.7, base ==4.9.0.0 -Currently staversion reads build plan YAML files that are stored locally in your computer. +staversion first reads build plan YAML files that are stored locally in your computer, then it tries to fetch them over network. ## TODO -- Fetch build plan YAML files from github.com -- Cache build plans in some local storage (SQLite?) -- Expand major version resolvers (lts-X) into full resolvers (lts-X.YY) - Search for the latest version numbers hosted in hackage. - Read `build-depends` sections .cabal files for package name queries. - Show version number ranges supported by the given resolvers. +- Cache build plans in some local storage (SQLite?) ## Author diff --git a/src/Staversion/Internal/BuildPlan.hs b/src/Staversion/Internal/BuildPlan.hs --- a/src/Staversion/Internal/BuildPlan.hs +++ b/src/Staversion/Internal/BuildPlan.hs @@ -5,29 +5,56 @@ -- -- __This is an internal module. End-users should not use it.__ module Staversion.Internal.BuildPlan - ( PackageName, + ( -- * Entry APIs BuildPlan, - loadBuildPlanYAML, packageVersion, - parseVersionText + BuildPlanManager, + newBuildPlanManager, + loadBuildPlan, + -- * Low-level APIs + loadBuildPlanYAML, + parseVersionText, + -- * For tests + _setDisambiguator ) where import Control.Applicative (empty, (<$>), (<*>)) -import Control.Exception (throwIO) +import Control.Exception (throwIO, catchJust, IOException, catch) +import Control.Monad.Trans.Except (runExceptT, ExceptT(..)) +import Control.Monad.IO.Class (liftIO) import Data.Aeson (FromJSON(..), (.:), Value(..), Object) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as HM +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (listToMaybe) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Traversable (Traversable(traverse)) import Data.Version (Version, parseVersion) import qualified Data.Yaml as Yaml +import System.FilePath ((), (<.>)) +import qualified System.IO.Error as IOE import Text.Read (readMaybe) import Text.ParserCombinators.ReadP (readP_to_S) -import Staversion.Internal.Query (PackageName) +import Staversion.Internal.Log + ( Logger, logDebug, logWarn + ) +import Staversion.Internal.HTTP (niceHTTPManager, Manager, OurHttpException) +import Staversion.Internal.Query + ( PackageName, PackageSource(..), + ErrorMsg, Resolver + ) +import Staversion.Internal.BuildPlan.Stackage + ( Disambiguator, + fetchDisambiguator, + parseResolverString, + formatResolverString, + PartialResolver(..), ExactResolver, + fetchBuildPlanYAML + ) -- | A data structure that keeps a map between package names and their -- versions. @@ -49,11 +76,105 @@ versionParser = maybe empty return . parseVersionText parseJSON _ = empty +-- | Stateful manager for 'BuildPlan's. +data BuildPlanManager = + BuildPlanManager { manBuildPlanDir :: FilePath, + -- ^ path to the directory where build plans are hold. + manHttpManager :: Maybe Manager, + -- ^ low-level HTTP connection manager. If 'Nothing', it won't fetch build plans over the network. + manDisambiguator :: IORef (Maybe Disambiguator), + -- ^ cache of resolver disambigutor + manLogger :: Logger + } +newBuildPlanManager :: FilePath -- ^ path to the directory where build plans are hold. + -> Logger + -> Bool -- ^ If 'True', it queries the Internet for build plans. Otherwise, it won't. + -> IO BuildPlanManager +newBuildPlanManager plan_dir logger enable_network = do + mman <- if enable_network + then Just <$> niceHTTPManager + else return Nothing + disam <- newIORef Nothing + return $ BuildPlanManager { manBuildPlanDir = plan_dir, + manHttpManager = mman, + manDisambiguator = disam, + manLogger = logger + } + +type LoadM = ExceptT ErrorMsg IO + +loggedElse :: Logger + -> LoadM a -- ^ first action tried. + -> LoadM a -- ^ the action executed if the first action returns 'Left'. + -> LoadM a +loggedElse logger first second = ExceptT $ do + eret <- runExceptT first + case eret of + Right _ -> return eret + Left e -> logWarn logger e >> runExceptT second + +maybeToLoadM :: ErrorMsg -> Maybe a -> LoadM a +maybeToLoadM msg = ExceptT . return . maybe (Left msg) Right + +httpExceptionToLoadM :: String -> LoadM a -> LoadM a +httpExceptionToLoadM context action = ExceptT $ (runExceptT action) `catch` handler where + handler :: OurHttpException -> IO (Either ErrorMsg a) + handler e = return $ Left (context ++ ": " ++ show e) + +loadBuildPlan :: BuildPlanManager -> PackageSource -> IO (Either ErrorMsg BuildPlan) +loadBuildPlan man (SourceStackage resolver) = runExceptT impl where + impl = loadBuildPlan_stackageLocalFile man resolver `loggedElse'` do + e_resolver <- tryDisambiguate man =<< getPresolver + loadBuildPlan_stackageLocalFile man (formatResolverString $ PartialExact e_resolver) `loggedElse'` loadBuildPlan_stackageNetwork man e_resolver + getPresolver = maybeToLoadM ("Invalid resolver format for stackage.org: " ++ resolver) $ parseResolverString resolver + loggedElse' = loggedElse $ manLogger man + +loadBuildPlan_stackageLocalFile :: BuildPlanManager -> Resolver -> LoadM BuildPlan +loadBuildPlan_stackageLocalFile man resolver = ExceptT $ catchJust handleIOError doLoad (return . Left) where + yaml_file = manBuildPlanDir man resolver <.> "yaml" + doLoad = do + logDebug (manLogger man) ("Read " ++ yaml_file ++ " for build plan.") + loadBuildPlanYAML yaml_file + handleIOError :: IOException -> Maybe ErrorMsg + handleIOError e | IOE.isDoesNotExistError e = Just $ makeErrorMsg e (yaml_file ++ " not found.") + | IOE.isPermissionError e = Just $ makeErrorMsg e ("you cannot open " ++ yaml_file ++ ".") + | otherwise = Just $ makeErrorMsg e ("some error.") + makeErrorMsg exception body = "Loading build plan for package resolver '" ++ resolver ++ "' failed: " ++ body ++ "\n" ++ show exception + +tryDisambiguate :: BuildPlanManager -> PartialResolver -> LoadM ExactResolver +tryDisambiguate _ (PartialExact e) = return e +tryDisambiguate bp_man presolver = impl where + impl = do + disam <- httpExceptionToLoadM "Failed to download disambiguator" $ getDisambiguator + maybeToLoadM ("Cannot disambiguate the resolver: " ++ show presolver) $ disam presolver + getDisambiguator = do + m_disam <- liftIO $ readIORef $ manDisambiguator bp_man + case m_disam of + Just d -> return d + Nothing -> do + http_man <- maybeToLoadM "It is not allowed to access network." $ manHttpManager bp_man + logDebug' "Fetch resolver disambiguator from network..." + got_d <- ExceptT $ fetchDisambiguator http_man + logDebug' "Successfully fetched resolver disambiguator." + liftIO $ writeIORef (manDisambiguator bp_man) $ Just got_d + return got_d + logDebug' = liftIO . logDebug (manLogger bp_man) + +loadBuildPlan_stackageNetwork :: BuildPlanManager -> ExactResolver -> LoadM BuildPlan +loadBuildPlan_stackageNetwork man e_resolver = do + http_man <- maybeToLoadM "It is not allowed to access network." $ manHttpManager man + liftIO $ logDebug (manLogger man) ("Fetch build plan from network: resolver = " ++ show e_resolver) + yaml_data <- httpExceptionToLoadM ("Downloading build plan failed: " ++ show e_resolver) $ liftIO $ fetchBuildPlanYAML http_man e_resolver + ExceptT $ return $ parseBuildPlanYAML $ BSL.toStrict yaml_data + +parseBuildPlanYAML :: BS.ByteString -> Either ErrorMsg BuildPlan +parseBuildPlanYAML = either (Left . toErrorMsg) Right . Yaml.decodeEither' where + toErrorMsg parse_exception = "Error while parsing BuildPlan YAML: " ++ show parse_exception + -- | Load a 'BuildPlan' from a file. -loadBuildPlanYAML :: FilePath -> IO BuildPlan -loadBuildPlanYAML yaml_file = (toException . Yaml.decodeEither') =<< BS.readFile yaml_file where -- TODO: make it memory-efficient! - toException = either (throwIO) return +loadBuildPlanYAML :: FilePath -> IO (Either ErrorMsg BuildPlan) +loadBuildPlanYAML yaml_file = parseBuildPlanYAML <$> BS.readFile yaml_file where -- TODO: make it memory-efficient! packageVersion :: BuildPlan -> PackageName -> Maybe Version packageVersion (BuildPlan bp_map) name = HM.lookup name bp_map @@ -63,3 +184,6 @@ parseVersionText :: Text -> Maybe Version parseVersionText = extractResult . (readP_to_S parseVersion) . unpack where extractResult = listToMaybe . map fst . filter (\pair -> snd pair == "") + +_setDisambiguator :: BuildPlanManager -> Maybe Disambiguator -> IO () +_setDisambiguator bp_man = writeIORef (manDisambiguator bp_man) diff --git a/src/Staversion/Internal/BuildPlan/Stackage.hs b/src/Staversion/Internal/BuildPlan/Stackage.hs new file mode 100644 --- /dev/null +++ b/src/Staversion/Internal/BuildPlan/Stackage.hs @@ -0,0 +1,120 @@ +-- | +-- Module: Staversion.Internal.BuildPlan.Stackage +-- Description: dealing with Stackage and build-plan repositories online. +-- Maintainer: Toshio Ito +-- +-- __This is an internal module. End-users should not use it.__ +-- +-- This module is meant to be exposed only to +-- "Staversion.Internal.BuildPlan" and test modules. +module Staversion.Internal.BuildPlan.Stackage + ( -- * High level API + ExactResolver(..), + PartialResolver(..), + parseResolverString, + formatResolverString, + Disambiguator, + fetchDisambiguator, + fetchBuildPlanYAML, + -- * Low level API + parseDisambiguator + ) where + +import Control.Monad (void) +import Control.Applicative ((<|>), (*>), (<$>), (<*>), empty, pure) +import qualified Control.Exception as Exception (handle) +import Data.Aeson (FromJSON(..), Value(..)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Function (on) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.List (sortBy) +import Data.Text (unpack) +import Data.Word (Word) +import Data.IORef (IORef) +import System.IO.Error (ioError, userError) +import qualified Text.ParserCombinators.ReadP as P +import Text.Printf (printf) +import Text.Read.Lex (readDecP) + +import Staversion.Internal.HTTP (Manager, fetchURL, OurHttpException) +import Staversion.Internal.Query (Resolver, ErrorMsg) + +-- | Non-ambiguous fully-resolved resolver for stackage. +data ExactResolver = ExactLTS Word Word -- ^ lts-(major).(minor) + | ExactNightly Word Word Word -- ^ nightly-(year)-(month)-(day) + deriving (Show,Eq,Ord) + +-- | Potentially partial resolver for stackage. +data PartialResolver = PartialExact ExactResolver + | PartialLTSLatest -- ^ lts (latest) + | PartialLTSMajor Word -- ^ lts-(major) + | PartialNightlyLatest -- ^ nightly (latest) + deriving (Show,Eq,Ord) + +parseResolverString :: Resolver -> Maybe PartialResolver +parseResolverString = getResult . P.readP_to_S parser where + getResult = fmap fst . listToMaybe . sortBy (compare `on` (length . snd)) + decimal = readDecP + parser = lts <|> nightly + lts = P.string "lts" *> ( lts_exact <|> lts_major <|> (P.eof *> pure PartialLTSLatest) ) + lts_exact = do + void $ P.char '-' + major <- decimal + void $ P.char '.' + minor <- decimal + return $ PartialExact $ ExactLTS major minor + lts_major = P.char '-' *> ( PartialLTSMajor <$> decimal ) + nightly = P.string "nightly" *> ( nightly_exact <|> (P.eof *> pure PartialNightlyLatest) ) + nightly_exact = do + void $ P.char '-' + year <- decimal + void $ P.char '-' + month <- decimal + void $ P.char '-' + day <- decimal + return $ PartialExact $ ExactNightly year month day + +formatResolverString :: PartialResolver -> Resolver +formatResolverString pr = case pr of + PartialExact (ExactLTS major minor) -> "lts-" ++ show major ++ "." ++ show minor + PartialExact (ExactNightly year month day) -> printf "nightly-%04d-%02d-%02d" year month day + PartialLTSLatest -> "lts" + PartialLTSMajor major -> "lts-" ++ show major + PartialNightlyLatest -> "nightly" + +type Disambiguator = PartialResolver -> Maybe ExactResolver + +-- | Fetch the 'Disambiguator' from the Internet. +fetchDisambiguator :: Manager -> IO (Either ErrorMsg Disambiguator) +fetchDisambiguator man = (return . toEither . parseDisambiguator) =<< fetchURL man disambiguator_url where + disambiguator_url = "https://www.stackage.org/download/snapshots.json" + toEither = maybe (Left ("Failed to parse disambiguator from" ++ disambiguator_url)) Right + +newtype DisamMap = DisamMap { unDisamMap :: M.Map PartialResolver ExactResolver } + +instance FromJSON DisamMap where + parseJSON (Object o) = fmap (DisamMap . M.fromList) $ mapM parsePair $ HM.toList o where + parsePair (k,v) = (,) <$> parseKey k <*> parseValue v + parseKey key = maybe empty return $ parseResolverString $ unpack key + parseValue v = (expectExact . parseResolverString) =<< parseJSON v + expectExact (Just (PartialExact e)) = return e + expectExact _ = empty + parseJSON _ = empty + +parseDisambiguator :: BSL.ByteString -- ^ disambiguation JSON text. + -> Maybe Disambiguator +parseDisambiguator input = toDisam <$> Aeson.decode input where + toDisam _ (PartialExact e) = Just e + toDisam dis_map key = M.lookup key (unDisamMap dis_map) + +-- | Fetch build plan YAML data from the Internet. +fetchBuildPlanYAML :: Manager -> ExactResolver -> IO BSL.ByteString +fetchBuildPlanYAML man resolver = fetchURL man url where + resolver_str = formatResolverString $ PartialExact $ resolver + url = case resolver of + ExactLTS _ _ -> "https://raw.githubusercontent.com/fpco/lts-haskell/master/" ++ resolver_str ++ ".yaml" + ExactNightly _ _ _ -> "https://raw.githubusercontent.com/fpco/stackage-nightly/master/" ++ resolver_str ++ ".yaml" + diff --git a/src/Staversion/Internal/Command.hs b/src/Staversion/Internal/Command.hs --- a/src/Staversion/Internal/Command.hs +++ b/src/Staversion/Internal/Command.hs @@ -36,9 +36,11 @@ -- ^ the logger commSources :: [PackageSource], -- ^ package sources to search - commQueries :: [Query] + commQueries :: [Query], -- ^ package queries - } deriving (Show,Eq) + commAllowNetwork :: Bool + -- ^ if 'True', it accesses the Internet to query build plans etc. + } deriving (Show) -- | Default values for 'Command'. data DefCommand = DefCommand { defBuildPlanDir :: FilePath @@ -52,7 +54,7 @@ commandParser :: DefCommand -> Opt.Parser Command -commandParser def_comm = Command <$> build_plan_dir <*> logger <*> sources <*> queries where +commandParser def_comm = Command <$> build_plan_dir <*> logger <*> sources <*> queries <*> network where logger = makeLogger <$> is_verbose makeLogger True = defaultLogger { loggerThreshold = Just LogDebug } makeLogger False = defaultLogger @@ -80,6 +82,10 @@ $ mconcat [ Opt.help "Name of package whose version you want to check.", Opt.metavar "PACKAGE_NAME" ] + network = not <$> no_network + no_network = Opt.switch $ mconcat [ Opt.long "no-network", + Opt.help "Forbid network access." + ] programDescription :: Opt.Parser a -> Opt.ParserInfo a programDescription parser = diff --git a/src/Staversion/Internal/Exec.hs b/src/Staversion/Internal/Exec.hs --- a/src/Staversion/Internal/Exec.hs +++ b/src/Staversion/Internal/Exec.hs @@ -10,23 +10,20 @@ ) where import Control.Applicative ((<$>)) -import Control.Exception (catchJust, IOException) import Data.Function (on) import Data.List (groupBy) import Data.Text (unpack) import qualified Data.Text.Lazy.IO as TLIO -import System.FilePath ((), (<.>)) -import qualified System.IO.Error as IOE import Staversion.Internal.BuildPlan - ( BuildPlan, loadBuildPlanYAML, packageVersion + ( BuildPlan, packageVersion, newBuildPlanManager, loadBuildPlan ) import Staversion.Internal.Command ( parseCommandArgs, Command(..) ) import Staversion.Internal.Format (formatResultsCabal) -import Staversion.Internal.Log (logDebug, logWarn) +import Staversion.Internal.Log (logDebug, logError) import Staversion.Internal.Query ( Query(..), Result(..), PackageSource(..), resultVersionsFromList, ResultVersions, @@ -39,11 +36,14 @@ (TLIO.putStr . formatResultsCabal) =<< (processCommand comm) processCommand :: Command -> IO [Result] -processCommand comm = fmap concat $ mapM processQueriesIn $ commSources comm where +processCommand comm = impl where + impl = do + bp_man <- newBuildPlanManager (commBuildPlanDir comm) (commLogger comm) (commAllowNetwork comm) + fmap concat $ mapM (processQueriesIn bp_man) $ commSources comm logger = commLogger comm - processQueriesIn source = do + processQueriesIn bp_man source = do logDebug logger ("Retrieve package source " ++ show source) - e_build_plan <- loadBuildPlan comm source + e_build_plan <- loadBuildPlan bp_man source logBuildPlanResult e_build_plan return $ map (makeResult source e_build_plan) $ commQueries comm makeResult source e_build_plan query = case e_build_plan of @@ -52,20 +52,7 @@ resultVersions = Right $ searchVersions build_plan query } logBuildPlanResult (Right _) = logDebug logger ("Successfully retrieved build plan.") - logBuildPlanResult (Left error_msg) = logWarn logger ("Failed to load build plan: " ++ error_msg) - -loadBuildPlan :: Command -> PackageSource -> IO (Either ErrorMsg BuildPlan) -loadBuildPlan comm source@(SourceStackage resolver) = catchJust handleIOError (Right <$> doLoad) (return . Left) where - yaml_file = commBuildPlanDir comm resolver <.> "yaml" - doLoad = do - logDebug (commLogger comm) ("Read " ++ yaml_file ++ " for build plan.") - loadBuildPlanYAML yaml_file - handleIOError :: IOException -> Maybe ErrorMsg - handleIOError e | IOE.isDoesNotExistError e = Just $ makeErrorMsg e (yaml_file ++ " not found.") - | IOE.isPermissionError e = Just $ makeErrorMsg e ("you cannot open " ++ yaml_file ++ ".") - | otherwise = Just $ makeErrorMsg e ("some error.") - makeErrorMsg exception body = "Loading build plan for package source " ++ show source ++ " failed: " ++ body ++ "\n" ++ show exception - + logBuildPlanResult (Left error_msg) = logError logger ("Failed to load build plan: " ++ error_msg) searchVersions :: BuildPlan -> Query -> ResultVersions searchVersions build_plan (QueryName package_name) = diff --git a/src/Staversion/Internal/HTTP.hs b/src/Staversion/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Staversion/Internal/HTTP.hs @@ -0,0 +1,57 @@ +-- | +-- Module: Staversion.Internal.HTTP +-- Description: compatibility wrapper for http-client +-- Maintainer: Toshio Ito +-- +-- Every module in this package should use this module instead of +-- "Network.HTTP.Client". +-- +-- __This is an internal module. End-users should not use it.__ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +module Staversion.Internal.HTTP + ( Manager, + OurHttpException, + niceHTTPManager, + fetchURL + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (throwIO, Exception, SomeException, catch) +import Data.Typeable (Typeable) +import qualified Data.ByteString.Lazy as BSL +import qualified Network.HTTP.Client as H +import Network.HTTP.Client (Manager, HttpException) +import Network.HTTP.Types (statusIsSuccessful) +import Network.HTTP.Client.TLS (tlsManagerSettings) + +data OurHttpException = ParseUrlException String SomeException + | StatusFailureException H.Request (H.Response ()) + | OtherHttpException H.HttpException + deriving (Show,Typeable) + +instance Exception OurHttpException + +niceHTTPManager :: IO Manager +niceHTTPManager = H.newManager $ H.managerSetProxy (H.proxyEnvironment Nothing) $ tlsManagerSettings + +makeRequest :: String -> Either SomeException H.Request +#if MIN_VERSION_http_client(0,4,30) +makeRequest = H.parseRequest +#else +makeRequest = fmap unCheck . H.parseUrl where + unCheck req = req { H.checkStatus = \_ _ _ -> Nothing } +#endif + +fetchURL :: Manager -> String -> IO BSL.ByteString +fetchURL man url = doFetch `catch` rethrower where + doFetch = do + req <- either (\err -> throwIO $ ParseUrlException url err) return $ makeRequest url + res <- H.httpLbs req man + checkResponseStatus res req + return $ H.responseBody res + checkResponseStatus res req = + if not $ statusIsSuccessful $ H.responseStatus res + then throwIO $ StatusFailureException req (const () <$> res) + else return () + rethrower :: H.HttpException -> IO a + rethrower e = throwIO $ OtherHttpException e diff --git a/src/Staversion/Internal/Log.hs b/src/Staversion/Internal/Log.hs --- a/src/Staversion/Internal/Log.hs +++ b/src/Staversion/Internal/Log.hs @@ -11,10 +11,14 @@ putLog, logDebug, logInfo, - logWarn + logWarn, + logError, + -- * For tests + _mockLogger ) where import Control.Monad (when) +import Data.IORef (IORef, newIORef, modifyIORef) import System.IO (Handle, stderr, hPutStrLn) data LogLevel = LogDebug @@ -25,12 +29,15 @@ data Logger = Logger { loggerThreshold :: Maybe LogLevel, -- ^ If 'Nothing', logging is disabled. - loggerHandle :: Handle - } deriving (Show,Eq) + loggerPutLogRaw :: LogLevel -> String -> IO () + } +instance Show Logger where + show l = "Logger { loggerThreshold = " ++ show (loggerThreshold l) ++ " }" + defaultLogger :: Logger defaultLogger = Logger { loggerThreshold = Just LogInfo, - loggerHandle = stderr + loggerPutLogRaw = \_ msg -> hPutStrLn stderr msg } toLabel :: LogLevel -> String @@ -41,9 +48,8 @@ LogError -> "[error]" putLog :: Logger -> LogLevel -> String -> IO () -putLog logger level raw_msg = when (fmap (level >=) mthreshold == Just True) $ hPutStrLn log_handle msg where +putLog logger level raw_msg = when (fmap (level >=) mthreshold == Just True) $ loggerPutLogRaw logger level msg where mthreshold = loggerThreshold logger - log_handle = loggerHandle logger msg = toLabel level ++ " " ++ raw_msg logDebug :: Logger -> String -> IO () @@ -54,4 +60,14 @@ logWarn :: Logger -> String -> IO () logWarn = flip putLog $ LogWarn + +logError :: Logger -> String -> IO () +logError = flip putLog $ LogError + +-- | FOR TEST: the IORef is the history of logged messages. +_mockLogger :: IO (Logger, IORef [(LogLevel, String)]) +_mockLogger = do + history <- newIORef [] + let puts level msg = modifyIORef history (++ [(level, msg)]) + return $ (defaultLogger { loggerPutLogRaw = puts }, history) diff --git a/staversion.cabal b/staversion.cabal --- a/staversion.cabal +++ b/staversion.cabal @@ -1,5 +1,5 @@ name: staversion -version: 0.1.0.0 +version: 0.1.1.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -14,7 +14,8 @@ -- Cabal's wild-card (*) doesn't match periods (.) test/data/lts-7.0_conpact.yaml, test/data/lts-4.2.yaml, - test/data/lts-2.22_conpact.yaml + test/data/lts-2.22_conpact.yaml, + test/data/snapshots.json homepage: https://github.com/debug-ito/staversion bug-reports: https://github.com/debug-ito/staversion/issues @@ -24,14 +25,16 @@ hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-imports default-extensions: OverloadedStrings - -- other-extensions: + other-extensions: CPP, DeriveDataTypeable exposed-modules: Staversion.Internal.BuildPlan, + Staversion.Internal.BuildPlan.Stackage, Staversion.Internal.Query, Staversion.Internal.Command, Staversion.Internal.Log, Staversion.Internal.Exec, Staversion.Internal.Format - other-modules: Paths_staversion + other-modules: Paths_staversion, + Staversion.Internal.HTTP build-depends: base >=4.6 && <4.10, unordered-containers >=0.2.3 && <0.3, aeson >=0.8.0 && <1.1, @@ -40,7 +43,13 @@ yaml >=0.8.3 && <0.9, filepath >=1.3.0 && <1.5, directory >=1.2.0 && <1.3, - optparse-applicative >=0.11.0 && <0.14 + optparse-applicative >=0.11.0 && <0.14, + containers >=0.5.5 && <0.6, + http-client >=0.4.18 && <0.6, + http-client-tls >=0.2.2 && <0.4, + http-types >=0.8.6 && <0.10, + transformers >=0.3.0 && <0.6, + transformers-compat >=0.4.0 && <0.6 executable staversion default-language: Haskell2010 @@ -56,16 +65,37 @@ type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test - ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + ghc-options: -Wall -fno-warn-unused-imports -fno-warn-orphans "-with-rtsopts=-M512m" main-is: Spec.hs default-extensions: OverloadedStrings -- other-extensions: other-modules: Staversion.Internal.BuildPlanSpec, + Staversion.Internal.BuildPlan.StackageSpec, Staversion.Internal.ExecSpec, Staversion.Internal.FormatSpec, Staversion.Internal.TestUtil - build-depends: base, staversion, text, filepath, - hspec >=2.1.7 && <2.4 + build-depends: base, staversion, text, filepath, bytestring, + hspec >=2.1.7 && <2.4, + QuickCheck + +flag network-test + description: Enable network tests. + default: False + +test-suite network-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports -fno-warn-orphans "-with-rtsopts=-M512m" + main-is: NetworkTest.hs + default-extensions: OverloadedStrings + if !flag(network-test) + buildable: False + -- other-extensions: + other-modules: Staversion.Internal.TestUtil + build-depends: base, staversion, http-client, http-client-tls, bytestring, + hspec + source-repository head type: git diff --git a/test/NetworkTest.hs b/test/NetworkTest.hs new file mode 100644 --- /dev/null +++ b/test/NetworkTest.hs @@ -0,0 +1,62 @@ +module Main (main,spec) where + +import qualified Data.ByteString.Lazy as BSL +import Network.HTTP.Client (newManager, Manager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Test.Hspec + +import Staversion.Internal.TestUtil (ver) + + +import Staversion.Internal.BuildPlan + ( newBuildPlanManager, + loadBuildPlan, + packageVersion + ) +import Staversion.Internal.BuildPlan.Stackage + ( fetchDisambiguator, + fetchBuildPlanYAML, + PartialResolver(..), ExactResolver(..) + ) +import Staversion.Internal.Log (defaultLogger, Logger(loggerThreshold)) +import Staversion.Internal.Query (PackageSource(..)) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + spec_Stackage + spec_BuildPlan + +spec_Stackage:: Spec +spec_Stackage = describe "BuildPlan.Stackage" $ beforeAll makeManager $ do + describe "fetchDisambiguator" $ do + it "fetches valid disambiguator" $ \man -> do + e_dis <- fetchDisambiguator man + case e_dis of + Left err -> expectationFailure ("should not be Left: " ++ err) + Right dis -> dis (PartialLTSMajor 2) `shouldBe` Just (ExactLTS 2 22) + describe "fetchBuildPlanYAML" $ do + it "fetches a LTS build plan" $ \man -> do + raw_yaml <- fetchBuildPlanYAML man (ExactLTS 2 22) + BSL.length raw_yaml `shouldSatisfy` (> 0) + it "fetchces a nightly build plan" $ \man -> do + raw_yaml <- fetchBuildPlanYAML man (ExactNightly 2016 10 20) + BSL.length raw_yaml `shouldSatisfy` (> 0) + +makeManager :: IO Manager +makeManager = newManager tlsManagerSettings + +spec_BuildPlan :: Spec +spec_BuildPlan = describe "BuildPlan" $ do + describe "loadBuildPlan from Stackage" $ do + it "disambiguates LTS version and fetches a valid BuildPlan" $ do + let logger = defaultLogger { loggerThreshold = Nothing } + bp_man <- newBuildPlanManager "." logger True + bp <- loadBuildPlan bp_man (SourceStackage "lts-5") >>= \ret -> case ret of + Right bp -> return bp + Left error_msg -> error ("loadBuildPlan failed: " ++ error_msg) + packageVersion bp "base" `shouldBe` Just (ver [4,8,2,0]) + packageVersion bp "bytestring" `shouldBe` Just (ver [0,10,6,0]) + packageVersion bp "conduit" `shouldBe` Just (ver [1,2,6,6]) diff --git a/test/Staversion/Internal/BuildPlan/StackageSpec.hs b/test/Staversion/Internal/BuildPlan/StackageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Staversion/Internal/BuildPlan/StackageSpec.hs @@ -0,0 +1,79 @@ +module Staversion.Internal.BuildPlan.StackageSpec (main,spec) where + +import Control.Applicative ((<$>), (<*>), pure) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import System.FilePath ((), (<.>)) +import Test.Hspec +import Test.QuickCheck (Arbitrary(..), oneof, property, Gen) + +import Staversion.Internal.BuildPlan.Stackage + ( parseResolverString, formatResolverString, + PartialResolver(..), ExactResolver(..), + Disambiguator, parseDisambiguator + ) + +instance Arbitrary ExactResolver where + arbitrary = oneof [ ExactLTS <$> arbitrary <*> arbitrary, + ExactNightly <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Arbitrary PartialResolver where + arbitrary = oneof [ PartialExact <$> arbitrary, + pure PartialLTSLatest, + PartialLTSMajor <$> arbitrary, + pure PartialNightlyLatest + ] + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + parse_spec + format_spec + parseDis_spec + +parse_spec :: Spec +parse_spec = describe "parseResolverString" $ do + ex "lts-7.0" (Just $ PartialExact $ ExactLTS 7 0) + ex "lts-2.22" (Just $ PartialExact $ ExactLTS 2 22) + ex "lts-4" (Just $ PartialLTSMajor 4) + ex "lts" (Just $ PartialLTSLatest) + ex "nightly-2016-10-21" (Just $ PartialExact $ ExactNightly 2016 10 21) + ex "nightly" (Just $ PartialNightlyLatest) + ex "hoge" Nothing + ex "lts-5." (Just $ PartialLTSMajor 5) + ex "lts-" Nothing + ex "nightly-2016" Nothing + ex "nightly-2016-10-" Nothing + where + ex input expected = specify input $ parseResolverString input `shouldBe` expected + +format_spec :: Spec +format_spec = describe "formatResolverString" $ do + it "should generate parsable string" $ property $ \presolver -> + (parseResolverString $ formatResolverString presolver) == Just presolver + it "should pad nightly month/day with 0" $ do + formatResolverString (PartialExact $ ExactNightly 2010 1 8) `shouldBe` "nightly-2010-01-08" + +parseDis_spec :: Spec +parseDis_spec = describe "parseDisambiguator" $ do + describe "snapshots.json" $ before (loadDisambiguator "snapshots.json") $ do + it "disambiguates exact resolvers" $ \dis -> property $ \p_exact -> do + dis (PartialExact p_exact) == Just p_exact + it "disambiguates lts-2" $ \dis -> do + dis (PartialLTSMajor 2) `shouldBe` Just (ExactLTS 2 22) + it "disambiguates lts" $ \dis -> do + dis (PartialLTSLatest) `shouldBe` Just (ExactLTS 7 5) + it "disambiguates nightly" $ \dis -> do + dis (PartialNightlyLatest) `shouldBe` Just (ExactNightly 2016 10 22) + it "cannot disambiguate lts future version" $ \dis -> do + dis (PartialLTSMajor 999) `shouldBe` Nothing + + +loadDisambiguator :: FilePath -> IO Disambiguator +loadDisambiguator file_name = expectJust =<< (parseDisambiguator <$> BSL.fromStrict <$> BS.readFile file_path) where + file_path = "test" "data" file_name + expectJust Nothing = error "parse should succeed" + expectJust (Just d) = return d diff --git a/test/Staversion/Internal/BuildPlanSpec.hs b/test/Staversion/Internal/BuildPlanSpec.hs --- a/test/Staversion/Internal/BuildPlanSpec.hs +++ b/test/Staversion/Internal/BuildPlanSpec.hs @@ -5,13 +5,22 @@ import System.FilePath ((), (<.>)) import Test.Hspec +import Staversion.Internal.Log (defaultLogger, loggerThreshold) +import Staversion.Internal.Query (PackageName, PackageSource(..)) import Staversion.Internal.BuildPlan - ( PackageName, - BuildPlan, + ( BuildPlan, loadBuildPlanYAML, packageVersion, - parseVersionText + parseVersionText, + BuildPlanManager, + newBuildPlanManager, + _setDisambiguator, + loadBuildPlan ) +import Staversion.Internal.BuildPlan.Stackage + ( Disambiguator, + PartialResolver(..), ExactResolver(..) + ) main :: IO () main = hspec spec @@ -20,6 +29,7 @@ spec = do parseVersionText_spec packageVersion_spec + loadBuildPlan_spec parseVersionText_spec :: Spec parseVersionText_spec = describe "parseVersionText" $ do @@ -50,9 +60,28 @@ forBuildPlan :: String -> (IO BuildPlan -> Spec) -> Spec forBuildPlan build_plan_base testWith = describe build_plan_base (testWith loader) where - loader = loadBuildPlanYAML ("test" "data" build_plan_base <.> "yaml") + loader = either error return =<< loadBuildPlanYAML ("test" "data" build_plan_base <.> "yaml") loadVersion :: PackageName -> IO BuildPlan -> IO (Maybe Version) loadVersion package_name loader = do plan <- loader return $ packageVersion plan package_name + + +mockBuildPlanManager :: Disambiguator -> IO BuildPlanManager +mockBuildPlanManager disam = do + bp_man <- newBuildPlanManager build_plan_dir logger False + _setDisambiguator bp_man (Just disam) + return bp_man + where + build_plan_dir = "test" "data" + logger = defaultLogger { loggerThreshold = Nothing } + +loadBuildPlan_spec :: Spec +loadBuildPlan_spec = describe "loadBuildPlan" $ do + it "reads local file after disambiguation" $ do + let disam (PartialLTSLatest) = Just $ ExactLTS 4 2 + disam _ = Nothing + bp_man <- mockBuildPlanManager disam + bp <- either (\e -> error ("Error: " ++ e)) return =<< loadBuildPlan bp_man (SourceStackage "lts") + packageVersion bp "base" `shouldBe` (Just $ Version [4,8,2,0] []) diff --git a/test/Staversion/Internal/ExecSpec.hs b/test/Staversion/Internal/ExecSpec.hs --- a/test/Staversion/Internal/ExecSpec.hs +++ b/test/Staversion/Internal/ExecSpec.hs @@ -1,6 +1,8 @@ module Staversion.Internal.ExecSpec (main,spec) where import Data.Version (Version(Version)) +import Data.IORef (readIORef) +import Data.List (isInfixOf) import System.FilePath (()) import Test.Hspec @@ -15,7 +17,7 @@ resultVersionsFromList, ErrorMsg ) -import Staversion.Internal.Log (defaultLogger, Logger(loggerThreshold), LogLevel(LogError)) +import Staversion.Internal.Log (defaultLogger, _mockLogger, Logger(loggerThreshold), LogLevel(..)) import Staversion.Internal.TestUtil (ver, rvers) @@ -31,11 +33,25 @@ singleCase (SourceStackage "conpact_build_plan") (QueryName "unknown") (Right $ rvers [("unknown", Nothing)]) specify "QueryName, SourceStackage, source not found" $ do - singleCase' (SourceStackage "unknown") (QueryName "drawille") $ \got -> case got of + (logger, logs) <- _mockLogger + let src = SourceStackage "unknown" + query = QueryName "drawille" + comm = baseCommand { commSources = [src], + commQueries = [query], + commLogger = logger { loggerThreshold = Just LogInfo } + } + [got_ret] <- processCommand comm + resultIn got_ret `shouldBe` src + resultFor got_ret `shouldBe` query + case resultVersions got_ret of Right _ -> expectationFailure "it should fail" - Left msg -> do - msg `shouldContain` "unknown.yaml" - msg `shouldContain` "not found" + Left _ -> return () + got_logs <- readIORef logs + let match :: (LogLevel, String) -> Bool + match (level, msg) = (level >= LogWarn) + && ("unknown.yaml" `isInfixOf` msg) + && ("not found" `isInfixOf` msg) + (length $ filter match got_logs) `shouldBe` 1 specify "QueryName, SourceStackage, full-mesh" $ do let src2 = SourceStackage "lts-2.22_conpact" src7 = SourceStackage "lts-7.0_conpact" @@ -77,5 +93,6 @@ baseCommand = Command { commBuildPlanDir = "test" "data", commLogger = defaultLogger { loggerThreshold = Nothing }, commSources = [], - commQueries = [] + commQueries = [], + commAllowNetwork = False } diff --git a/test/data/snapshots.json b/test/data/snapshots.json new file mode 100644 --- /dev/null +++ b/test/data/snapshots.json @@ -0,0 +1,1 @@ +{"lts-2":"lts-2.22","lts-4":"lts-4.2","lts-3":"lts-3.22","lts-5":"lts-5.18","lts":"lts-7.5","lts-0":"lts-0.7","nightly":"nightly-2016-10-22","lts-1":"lts-1.15","lts-6":"lts-6.23","lts-7":"lts-7.5"}