staversion 0.1.0.0 → 0.1.1.0
raw patch · 14 files changed
+593/−61 lines, 14 filesdep +QuickCheckdep +containersdep +http-clientdep ~basedep ~bytestringdep ~hspec
Dependencies added: QuickCheck, containers, http-client, http-client-tls, http-types, transformers, transformers-compat
Dependency ranges changed: base, bytestring, hspec
Files
- ChangeLog.md +6/−0
- README.md +2/−4
- src/Staversion/Internal/BuildPlan.hs +132/−8
- src/Staversion/Internal/BuildPlan/Stackage.hs +120/−0
- src/Staversion/Internal/Command.hs +9/−3
- src/Staversion/Internal/Exec.hs +9/−22
- src/Staversion/Internal/HTTP.hs +57/−0
- src/Staversion/Internal/Log.hs +22/−6
- staversion.cabal +38/−8
- test/NetworkTest.hs +62/−0
- test/Staversion/Internal/BuildPlan/StackageSpec.hs +79/−0
- test/Staversion/Internal/BuildPlanSpec.hs +33/−4
- test/Staversion/Internal/ExecSpec.hs +23/−6
- test/data/snapshots.json +1/−0
ChangeLog.md view
@@ -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.
README.md view
@@ -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
src/Staversion/Internal/BuildPlan.hs view
@@ -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)
+ src/Staversion/Internal/BuildPlan/Stackage.hs view
@@ -0,0 +1,120 @@+-- |+-- Module: Staversion.Internal.BuildPlan.Stackage+-- Description: dealing with Stackage and build-plan repositories online.+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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"+
src/Staversion/Internal/Command.hs view
@@ -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 =
src/Staversion/Internal/Exec.hs view
@@ -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) =
+ src/Staversion/Internal/HTTP.hs view
@@ -0,0 +1,57 @@+-- |+-- Module: Staversion.Internal.HTTP+-- Description: compatibility wrapper for http-client +-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- 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
src/Staversion/Internal/Log.hs view
@@ -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)
staversion.cabal view
@@ -1,5 +1,5 @@ name: staversion-version: 0.1.0.0+version: 0.1.1.0 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> 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
+ test/NetworkTest.hs view
@@ -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])
+ test/Staversion/Internal/BuildPlan/StackageSpec.hs view
@@ -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
test/Staversion/Internal/BuildPlanSpec.hs view
@@ -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] [])
test/Staversion/Internal/ExecSpec.hs view
@@ -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 }
+ test/data/snapshots.json view
@@ -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"}