mirror of
https://github.com/nmattia/niv.git
synced 2024-09-16 01:47:08 +03:00
New update mechanism
This commit is contained in:
parent
65786ee156
commit
7789b95124
185
app/Niv.hs
185
app/Niv.hs
@ -7,17 +7,20 @@
|
|||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
module Niv where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
|
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.=))
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.FileEmbed (embedFile)
|
import Data.FileEmbed (embedFile)
|
||||||
import Data.Functor ((<&>))
|
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import Data.Maybe (mapMaybe, fromMaybe)
|
import Data.Maybe (mapMaybe, fromMaybe)
|
||||||
import Data.String.QQ (s)
|
import Data.String.QQ (s)
|
||||||
import GHC.Exts (toList)
|
import Niv.GitHub
|
||||||
|
import Niv.Test
|
||||||
|
import Niv.Update
|
||||||
import System.Exit (exitFailure)
|
import System.Exit (exitFailure)
|
||||||
import System.FilePath ((</>), takeDirectory)
|
import System.FilePath ((</>), takeDirectory)
|
||||||
import System.Process (readProcess)
|
import System.Process (readProcess)
|
||||||
@ -31,10 +34,10 @@ import qualified Data.HashMap.Strict as HMS
|
|||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.IO as T
|
import qualified Data.Text.IO as T
|
||||||
import qualified GitHub as GH
|
import qualified GitHub as GH
|
||||||
import qualified GitHub.Data.Name as GH
|
|
||||||
import qualified Options.Applicative as Opts
|
import qualified Options.Applicative as Opts
|
||||||
import qualified Options.Applicative.Help.Pretty as Opts
|
import qualified Options.Applicative.Help.Pretty as Opts
|
||||||
import qualified System.Directory as Dir
|
import qualified System.Directory as Dir
|
||||||
|
import qualified Test.Tasty as Tasty
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = join $ Opts.execParser opts
|
main = join $ Opts.execParser opts
|
||||||
@ -86,9 +89,13 @@ parsePackageName :: Opts.Parser PackageName
|
|||||||
parsePackageName = PackageName <$>
|
parsePackageName = PackageName <$>
|
||||||
Opts.argument Opts.str (Opts.metavar "PACKAGE")
|
Opts.argument Opts.str (Opts.metavar "PACKAGE")
|
||||||
|
|
||||||
newtype PackageSpec = PackageSpec { _unPackageSpec :: Aeson.Object }
|
newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object }
|
||||||
deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid)
|
deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid)
|
||||||
|
|
||||||
|
-- | Simply discards the 'Freedom'
|
||||||
|
attrsToSpec :: Attrs -> PackageSpec
|
||||||
|
attrsToSpec = PackageSpec . fmap snd
|
||||||
|
|
||||||
parsePackageSpec :: Opts.Parser PackageSpec
|
parsePackageSpec :: Opts.Parser PackageSpec
|
||||||
parsePackageSpec =
|
parsePackageSpec =
|
||||||
(PackageSpec . HMS.fromList . fmap fixupAttributes) <$>
|
(PackageSpec . HMS.fromList . fmap fixupAttributes) <$>
|
||||||
@ -126,6 +133,7 @@ parsePackageSpec =
|
|||||||
shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>
|
shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>
|
||||||
[ "branch", "owner", "repo", "version" ]
|
[ "branch", "owner", "repo", "version" ]
|
||||||
|
|
||||||
|
-- TODO: infer those shortcuts from 'Update' keys
|
||||||
mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, T.Text)
|
mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, T.Text)
|
||||||
mkShortcutAttribute = \case
|
mkShortcutAttribute = \case
|
||||||
attr@(T.uncons -> Just (c,_)) -> (attr,) <$> Opts.strOption
|
attr@(T.uncons -> Just (c,_)) -> (attr,) <$> Opts.strOption
|
||||||
@ -150,113 +158,8 @@ parsePackage = (,) <$> parsePackageName <*> parsePackageSpec
|
|||||||
-- PACKAGE SPEC OPS
|
-- PACKAGE SPEC OPS
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
updatePackageSpec :: PackageSpec -> IO PackageSpec
|
test :: IO ()
|
||||||
updatePackageSpec = execStateT $ do
|
test = Tasty.defaultMain $ Niv.Test.tests
|
||||||
originalUrl <- getPackageSpecAttr "url"
|
|
||||||
|
|
||||||
-- Figures out the URL from the template
|
|
||||||
withPackageSpecAttr "url_template" (\case
|
|
||||||
Aeson.String (T.unpack -> template) -> do
|
|
||||||
packageSpec <- get
|
|
||||||
let stringValues = packageSpecStringValues packageSpec
|
|
||||||
case renderTemplate stringValues template of
|
|
||||||
Just renderedURL ->
|
|
||||||
setPackageSpecAttr "url" (Aeson.String $ T.pack renderedURL)
|
|
||||||
Nothing -> pure ()
|
|
||||||
_ -> pure ()
|
|
||||||
)
|
|
||||||
|
|
||||||
-- If the type attribute is not set, we try to infer its value based on the url suffix
|
|
||||||
(,) <$> getPackageSpecAttr "type" <*> getPackageSpecAttr "url" >>= \case
|
|
||||||
-- If an url type is set, we'll use it
|
|
||||||
(Just _, _) -> pure ()
|
|
||||||
-- We need an url to infer a url type
|
|
||||||
(_, Nothing) -> pure ()
|
|
||||||
(Nothing, Just (Aeson.String url)) -> do
|
|
||||||
let urlType = if "tar.gz" `T.isSuffixOf` url
|
|
||||||
then "tarball"
|
|
||||||
else "file"
|
|
||||||
setPackageSpecAttr "type" (Aeson.String $ T.pack urlType)
|
|
||||||
-- If the JSON value is not a string, we ignore it
|
|
||||||
(_, _) -> pure ()
|
|
||||||
|
|
||||||
-- Updates the sha256 based on the URL contents
|
|
||||||
(,) <$> getPackageSpecAttr "url" <*> getPackageSpecAttr "sha256" >>= \case
|
|
||||||
-- If no URL is set, we simply can't prefetch
|
|
||||||
(Nothing, _) -> pure ()
|
|
||||||
|
|
||||||
-- If an URL is set and no sha is set, /do/ update
|
|
||||||
(Just url, Nothing) -> prefetch url
|
|
||||||
|
|
||||||
-- If both the URL and sha are set, update only if the url has changed
|
|
||||||
(Just url, Just{}) -> when (Just url /= originalUrl) (prefetch url)
|
|
||||||
where
|
|
||||||
prefetch :: Aeson.Value -> StateT PackageSpec IO ()
|
|
||||||
prefetch = \case
|
|
||||||
Aeson.String (T.unpack -> url) -> do
|
|
||||||
unpack <- getPackageSpecAttr "type" <&> \case
|
|
||||||
-- Do not unpack if the url type is 'file'
|
|
||||||
Just (Aeson.String urlType) -> not $ T.unpack urlType == "file"
|
|
||||||
_ -> True
|
|
||||||
sha256 <- liftIO $ nixPrefetchURL unpack url
|
|
||||||
setPackageSpecAttr "sha256" (Aeson.String $ T.pack sha256)
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
completePackageSpec
|
|
||||||
:: PackageSpec
|
|
||||||
-> IO (PackageSpec)
|
|
||||||
completePackageSpec = execStateT $ do
|
|
||||||
|
|
||||||
-- In case we have @owner@ and @repo@, pull some data from GitHub
|
|
||||||
(,) <$> getPackageSpecAttr "owner" <*> getPackageSpecAttr "repo" >>= \case
|
|
||||||
(Just (Aeson.String owner), Just (Aeson.String repo)) -> do
|
|
||||||
liftIO (GH.executeRequest' $ GH.repositoryR (GH.N owner) (GH.N repo))
|
|
||||||
>>= \case
|
|
||||||
Left e ->
|
|
||||||
liftIO $ warnCouldNotFetchGitHubRepo e (T.unpack owner, T.unpack repo)
|
|
||||||
Right ghRepo -> do
|
|
||||||
|
|
||||||
-- Description
|
|
||||||
whenNotSet "description" $ case GH.repoDescription ghRepo of
|
|
||||||
Just descr ->
|
|
||||||
setPackageSpecAttr "description" (Aeson.String descr)
|
|
||||||
Nothing -> pure ()
|
|
||||||
|
|
||||||
whenNotSet "homepage" $ case GH.repoHomepage ghRepo of
|
|
||||||
Just descr ->
|
|
||||||
setPackageSpecAttr "homepage" (Aeson.String descr)
|
|
||||||
Nothing -> pure ()
|
|
||||||
|
|
||||||
-- Branch and rev
|
|
||||||
whenNotSet "branch" $ case GH.repoDefaultBranch ghRepo of
|
|
||||||
Just branch ->
|
|
||||||
setPackageSpecAttr "branch" (Aeson.String branch)
|
|
||||||
Nothing -> pure ()
|
|
||||||
|
|
||||||
withPackageSpecAttr "branch" (\case
|
|
||||||
Aeson.String branch -> do
|
|
||||||
liftIO (GH.executeRequest' $
|
|
||||||
GH.commitsWithOptionsForR
|
|
||||||
(GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
|
|
||||||
[GH.CommitQuerySha branch]) >>= \case
|
|
||||||
Right (toList -> (commit:_)) -> do
|
|
||||||
let GH.N rev = GH.commitSha commit
|
|
||||||
setPackageSpecAttr "rev" (Aeson.String rev)
|
|
||||||
_ -> pure ()
|
|
||||||
_ -> pure ()
|
|
||||||
)
|
|
||||||
(_,_) -> pure ()
|
|
||||||
|
|
||||||
-- Figures out the URL template
|
|
||||||
whenNotSet "url_template" $
|
|
||||||
setPackageSpecAttr
|
|
||||||
"url_template"
|
|
||||||
(Aeson.String githubURLTemplate)
|
|
||||||
|
|
||||||
where
|
|
||||||
githubURLTemplate :: T.Text
|
|
||||||
githubURLTemplate =
|
|
||||||
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- PackageSpec State helpers
|
-- PackageSpec State helpers
|
||||||
@ -382,18 +285,14 @@ parseCmdAdd =
|
|||||||
]
|
]
|
||||||
|
|
||||||
cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO ()
|
cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO ()
|
||||||
cmdAdd mPackageName (PackageName str, spec) = do
|
cmdAdd mPackageName (PackageName str, cliSpec) = do
|
||||||
|
|
||||||
-- Figures out the owner and repo
|
-- Figures out the owner and repo
|
||||||
(packageName, spec') <- flip runStateT spec $ case T.span (/= '/') str of
|
let (packageName, defaultSpec) = case T.span (/= '/') str of
|
||||||
( owner@(T.null -> False)
|
( owner@(T.null -> False)
|
||||||
, T.uncons -> Just ('/', repo@(T.null -> False))) -> do
|
, T.uncons -> Just ('/', repo@(T.null -> False))) -> do
|
||||||
whenNotSet "owner" $
|
(PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ])
|
||||||
setPackageSpecAttr "owner" (Aeson.String owner)
|
_ -> (PackageName str, HMS.empty)
|
||||||
whenNotSet "repo" $ do
|
|
||||||
setPackageSpecAttr "repo" (Aeson.String repo)
|
|
||||||
pure (PackageName repo)
|
|
||||||
_ -> pure (PackageName str)
|
|
||||||
|
|
||||||
sources <- unSources <$> getSources
|
sources <- unSources <$> getSources
|
||||||
|
|
||||||
@ -402,7 +301,11 @@ cmdAdd mPackageName (PackageName str, spec) = do
|
|||||||
when (HMS.member packageName' sources) $
|
when (HMS.member packageName' sources) $
|
||||||
abortCannotAddPackageExists packageName'
|
abortCannotAddPackageExists packageName'
|
||||||
|
|
||||||
spec'' <- updatePackageSpec =<< completePackageSpec spec'
|
let defaultSpec' = PackageSpec $ defaultSpec
|
||||||
|
|
||||||
|
spec'' <- attrsToSpec <$> evalUpdate
|
||||||
|
(specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec')
|
||||||
|
(githubUpdate nixPrefetchURL githubLatestRev githubRepo)
|
||||||
|
|
||||||
putStrLn $ "Writing new sources file"
|
putStrLn $ "Writing new sources file"
|
||||||
setSources $ Sources $
|
setSources $ Sources $
|
||||||
@ -415,6 +318,7 @@ cmdAdd mPackageName (PackageName str, spec) = do
|
|||||||
parseCmdShow :: Opts.ParserInfo (IO ())
|
parseCmdShow :: Opts.ParserInfo (IO ())
|
||||||
parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc
|
parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc
|
||||||
|
|
||||||
|
-- TODO: nicer output
|
||||||
cmdShow :: IO ()
|
cmdShow :: IO ()
|
||||||
cmdShow = do
|
cmdShow = do
|
||||||
putStrLn $ "Showing sources file"
|
putStrLn $ "Showing sources file"
|
||||||
@ -450,6 +354,13 @@ parseCmdUpdate =
|
|||||||
" niv update my-package -v beta-0.2"
|
" niv update my-package -v beta-0.2"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
specToFreeAttrs :: PackageSpec -> Attrs
|
||||||
|
specToFreeAttrs = fmap (Free,) . unPackageSpec
|
||||||
|
|
||||||
|
specToLockedAttrs :: PackageSpec -> Attrs
|
||||||
|
specToLockedAttrs = fmap (Locked,) . unPackageSpec
|
||||||
|
|
||||||
|
-- TODO: sexy logging + concurrent updates
|
||||||
cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO ()
|
cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO ()
|
||||||
cmdUpdate = \case
|
cmdUpdate = \case
|
||||||
Just (packageName, packageSpec) -> do
|
Just (packageName, packageSpec) -> do
|
||||||
@ -458,10 +369,9 @@ cmdUpdate = \case
|
|||||||
|
|
||||||
packageSpec' <- case HMS.lookup packageName sources of
|
packageSpec' <- case HMS.lookup packageName sources of
|
||||||
Just packageSpec' -> do
|
Just packageSpec' -> do
|
||||||
|
attrsToSpec <$> evalUpdate
|
||||||
-- TODO: something fishy happening here
|
(specToLockedAttrs packageSpec <> specToFreeAttrs packageSpec')
|
||||||
pkgSpec <- completePackageSpec $ packageSpec <> packageSpec'
|
(githubUpdate nixPrefetchURL githubLatestRev githubRepo)
|
||||||
updatePackageSpec $ pkgSpec
|
|
||||||
|
|
||||||
Nothing -> abortCannotUpdateNoSuchPackage packageName
|
Nothing -> abortCannotUpdateNoSuchPackage packageName
|
||||||
|
|
||||||
@ -474,7 +384,9 @@ cmdUpdate = \case
|
|||||||
sources' <- forWithKeyM sources $
|
sources' <- forWithKeyM sources $
|
||||||
\packageName packageSpec -> do
|
\packageName packageSpec -> do
|
||||||
T.putStrLn $ "Package: " <> unPackageName packageName
|
T.putStrLn $ "Package: " <> unPackageName packageName
|
||||||
updatePackageSpec =<< completePackageSpec packageSpec
|
attrsToSpec <$> evalUpdate
|
||||||
|
(specToFreeAttrs packageSpec)
|
||||||
|
(githubUpdate nixPrefetchURL githubLatestRev githubRepo)
|
||||||
|
|
||||||
setSources $ Sources sources'
|
setSources $ Sources sources'
|
||||||
|
|
||||||
@ -587,31 +499,16 @@ mapWithKeyM_ f m = do
|
|||||||
forM_ (HMS.toList m) $ \(k, v) ->
|
forM_ (HMS.toList m) $ \(k, v) ->
|
||||||
HMS.singleton k <$> f k v
|
HMS.singleton k <$> f k v
|
||||||
|
|
||||||
-- | Renders the template. Returns 'Nothing' if some of the attributes are
|
|
||||||
-- missing.
|
|
||||||
--
|
|
||||||
-- renderTemplate [("foo", "bar")] "<foo>" == Just "bar"
|
|
||||||
-- renderTemplate [("foo", "bar")] "<baz>" == Nothing
|
|
||||||
renderTemplate :: [(String, String)] -> String -> Maybe String
|
|
||||||
renderTemplate vals = \case
|
|
||||||
'<':str -> do
|
|
||||||
case span (/= '>') str of
|
|
||||||
(key, '>':rest) ->
|
|
||||||
liftA2 (<>) (lookup key vals) (renderTemplate vals rest)
|
|
||||||
_ -> Nothing
|
|
||||||
c:str -> (c:) <$> renderTemplate vals str
|
|
||||||
[] -> Just []
|
|
||||||
|
|
||||||
abort :: T.Text -> IO a
|
abort :: T.Text -> IO a
|
||||||
abort msg = do
|
abort msg = do
|
||||||
T.putStrLn msg
|
T.putStrLn msg
|
||||||
exitFailure
|
exitFailure
|
||||||
|
|
||||||
nixPrefetchURL :: Bool -> String -> IO String
|
nixPrefetchURL :: Bool -> T.Text -> IO T.Text
|
||||||
nixPrefetchURL unpack url =
|
nixPrefetchURL unpack (T.unpack -> url) =
|
||||||
lines <$> readProcess "nix-prefetch-url" args "" >>=
|
lines <$> readProcess "nix-prefetch-url" args "" >>=
|
||||||
\case
|
\case
|
||||||
(l:_) -> pure l
|
(l:_) -> pure (T.pack l)
|
||||||
_ -> abortNixPrefetchExpectedOutput
|
_ -> abortNixPrefetchExpectedOutput
|
||||||
where args = if unpack then ["--unpack", url] else [url]
|
where args = if unpack then ["--unpack", url] else [url]
|
||||||
|
|
||||||
|
10
default.nix
10
default.nix
@ -15,6 +15,11 @@ with rec
|
|||||||
[ "^package.yaml$"
|
[ "^package.yaml$"
|
||||||
"^app$"
|
"^app$"
|
||||||
"^app.*.hs$"
|
"^app.*.hs$"
|
||||||
|
"^src$"
|
||||||
|
"^src/Niv$"
|
||||||
|
"^src/Niv/GitHub$"
|
||||||
|
"^src/Niv/Update$"
|
||||||
|
"^src.*.hs$"
|
||||||
"^README.md$"
|
"^README.md$"
|
||||||
"^nix$"
|
"^nix$"
|
||||||
"^nix.sources.nix$"
|
"^nix.sources.nix$"
|
||||||
@ -29,7 +34,8 @@ with rec
|
|||||||
shellHook =
|
shellHook =
|
||||||
''
|
''
|
||||||
repl() {
|
repl() {
|
||||||
ghci app/Niv.hs
|
shopt -s globstar
|
||||||
|
ghci -Wall app/**/*.hs src/**/*.hs
|
||||||
}
|
}
|
||||||
|
|
||||||
echo "To start a REPL session, run:"
|
echo "To start a REPL session, run:"
|
||||||
@ -94,6 +100,8 @@ rec
|
|||||||
[ $expected_hash == $actual_hash ] && echo dymmy > $out || err
|
[ $expected_hash == $actual_hash ] && echo dymmy > $out || err
|
||||||
'';
|
'';
|
||||||
|
|
||||||
|
|
||||||
|
# TODO: use nivForTest for this one
|
||||||
niv-svg-cmds = pkgs.writeScript "niv-svg-cmds"
|
niv-svg-cmds = pkgs.writeScript "niv-svg-cmds"
|
||||||
''
|
''
|
||||||
#!${pkgs.stdenv.shell}
|
#!${pkgs.stdenv.shell}
|
||||||
|
51
package.yaml
51
package.yaml
@ -6,24 +6,41 @@ ghc-options:
|
|||||||
- -Wall
|
- -Wall
|
||||||
- -Werror
|
- -Werror
|
||||||
|
|
||||||
executable:
|
dependencies:
|
||||||
main: app/Niv.hs
|
- base
|
||||||
|
- text
|
||||||
|
- mtl
|
||||||
|
- unliftio
|
||||||
|
|
||||||
|
library:
|
||||||
|
source-dirs:
|
||||||
|
- src
|
||||||
dependencies:
|
dependencies:
|
||||||
- base
|
|
||||||
- hashable
|
|
||||||
- file-embed
|
|
||||||
- process
|
|
||||||
- text
|
|
||||||
- bytestring
|
|
||||||
- aeson
|
- aeson
|
||||||
- aeson-pretty
|
|
||||||
- directory
|
|
||||||
- string-qq
|
|
||||||
- filepath
|
|
||||||
- github
|
- github
|
||||||
- mtl
|
- tasty
|
||||||
- optparse-applicative
|
- tasty-hunit
|
||||||
- unliftio
|
|
||||||
- unordered-containers
|
- unordered-containers
|
||||||
data-files:
|
|
||||||
- nix/sources.nix
|
executables:
|
||||||
|
niv:
|
||||||
|
source-dirs:
|
||||||
|
- app
|
||||||
|
main: Niv.main
|
||||||
|
data-files:
|
||||||
|
- nix/sources.nix
|
||||||
|
dependencies:
|
||||||
|
- aeson
|
||||||
|
- aeson-pretty
|
||||||
|
- bytestring
|
||||||
|
- directory
|
||||||
|
- filepath
|
||||||
|
- github
|
||||||
|
- hashable
|
||||||
|
- file-embed
|
||||||
|
- niv
|
||||||
|
- optparse-applicative
|
||||||
|
- process
|
||||||
|
- string-qq
|
||||||
|
- tasty
|
||||||
|
- unordered-containers
|
||||||
|
@ -11,6 +11,6 @@ export NIX_PATH="nixpkgs=./nix"
|
|||||||
echo "Building"
|
echo "Building"
|
||||||
|
|
||||||
# Build and create a root
|
# Build and create a root
|
||||||
nix-build --no-link
|
nix-build --sandbox --no-link --max-jobs 10
|
||||||
|
|
||||||
echo "all good"
|
echo "all good"
|
||||||
|
@ -1,10 +1,10 @@
|
|||||||
<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" id="e7be124f4eec8170d74afbc28a4a5f02" baseProfile="full" viewBox="0 0 703 523" width="703" version="1.1">
|
<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" id="da2b5e7cef46c2eb6a8cb3f6111a7153" baseProfile="full" viewBox="0 0 703 523" width="703" version="1.1">
|
||||||
<defs>
|
<defs>
|
||||||
<termtosvg:template_settings xmlns:termtosvg="https://github.com/nbedos/termtosvg">
|
<termtosvg:template_settings xmlns:termtosvg="https://github.com/nbedos/termtosvg">
|
||||||
<termtosvg:screen_geometry columns="82" rows="26"/>
|
<termtosvg:screen_geometry columns="82" rows="26"/>
|
||||||
</termtosvg:template_settings>
|
</termtosvg:template_settings>
|
||||||
<style type="text/css" id="generated-style"><![CDATA[:root {
|
<style type="text/css" id="generated-style"><![CDATA[:root {
|
||||||
--animation-duration: 5500ms;
|
--animation-duration: 1000ms;
|
||||||
}
|
}
|
||||||
|
|
||||||
#screen {
|
#screen {
|
||||||
@ -44,5 +44,5 @@
|
|||||||
<circle cx="44" cy="23" r="7" class="color3"/>
|
<circle cx="44" cy="23" r="7" class="color3"/>
|
||||||
<circle cx="64" cy="23" r="7" class="color2"/>
|
<circle cx="64" cy="23" r="7" class="color2"/>
|
||||||
<svg id="screen" width="656" x="23" y="50" viewBox="0 0 656 442" preserveAspectRatio="xMidYMin meet">
|
<svg id="screen" width="656" x="23" y="50" viewBox="0 0 656 442" preserveAspectRatio="xMidYMin meet">
|
||||||
<rect class="background" height="100%" width="100%" x="0" y="0"/><g display="none"><rect class="foreground" height="17" width="8" x="0" y="85"/><use y="85" xlink:href="#g1"/><animate attributeName="display" begin="0ms; anim_last.end" dur="1500ms" from="inline" to="inline"/></g><g display="none"><rect class="foreground" height="17" width="8" x="0" y="187"/><use y="187" xlink:href="#g1"/><animate attributeName="display" begin="1500ms; anim_last.end+1500ms" dur="1500ms" from="inline" to="inline"/></g><g display="none"><rect class="foreground" height="17" width="8" x="0" y="306"/><use y="306" xlink:href="#g1"/><animate attributeName="display" begin="3000ms; anim_last.end+3000ms" dur="1500ms" from="inline" to="inline"/></g><g display="none"><use y="0" xlink:href="#g2"/><use y="17" xlink:href="#g3"/><use y="34" xlink:href="#g4"/><use y="51" xlink:href="#g5"/><use y="68" xlink:href="#g6"/><animate attributeName="display" begin="0ms; anim_last.end" dur="5500ms" from="inline" to="inline"/></g><g display="none"><use y="85" xlink:href="#g7"/><use y="102" xlink:href="#g8"/><use y="119" xlink:href="#g9"/><use y="136" xlink:href="#g10"/><use y="153" xlink:href="#g11"/><use y="170" xlink:href="#g6"/><animate attributeName="display" begin="1500ms; anim_last.end+1500ms" dur="4000ms" from="inline" to="inline"/></g><g display="none"><use y="272" xlink:href="#g12"/><use y="289" xlink:href="#g6"/><use y="187" xlink:href="#g7"/><use y="204" xlink:href="#g13"/><use y="221" xlink:href="#g14"/><use y="238" xlink:href="#g10"/><animate attributeName="display" begin="3000ms; anim_last.end+3000ms" dur="2500ms" from="inline" to="inline"/></g><g display="none"><use y="306" xlink:href="#g7"/><use y="323" xlink:href="#g15"/><use y="340" xlink:href="#g16"/><use y="357" xlink:href="#g10"/><rect class="foreground" height="17" width="8" x="0" y="374"/><use y="374" xlink:href="#g1"/><animate attributeName="display" begin="4500ms; anim_last.end+4500ms" dur="1000ms" from="inline" to="inline" id="anim_last"/></g><defs><g id="g1"><text class="background" textLength="8" x="0"> </text></g><g id="g2"><text class="foreground" textLength="80" x="0">$ niv init</text></g><g id="g3"><text class="foreground" textLength="192" x="0">Creating nix/sources.nix</text></g><g id="g4"><text class="foreground" textLength="200" x="0">Creating nix/sources.json</text></g><g id="g5"><text class="foreground" textLength="152" x="0">Importing 'niv' ...</text></g><g id="g6"><text class="foreground" textLength="160" x="0">Reading sources file</text></g><g id="g7"><text class="foreground" textLength="96" x="0">unpacking...</text></g><g id="g8"><text class="foreground" textLength="656" x="0">path is '/nix/store/bypafdfyf7q6fg1m1xxps4gv4adwwlxb-2f95c55006d6138aafe44e452350c</text></g><g id="g9"><text class="foreground" textLength="152" x="0">e7fa3211dfd.tar.gz'</text></g><g id="g10"><text class="foreground" textLength="192" x="0">Writing new sources file</text></g><g id="g11"><text class="foreground" textLength="184" x="0">Importing 'nixpkgs' ...</text></g><g id="g12"><text class="foreground" textLength="168" x="0">$ niv add stedolan/jq</text></g><g id="g13"><text class="foreground" textLength="656" x="0">path is '/nix/store/qbzbhgq78m94j4dm026y7mi7nkd4lgh4-a7e559a5504572008567383c3dc8e</text></g><g id="g14"><text class="foreground" textLength="152" x="0">142fa7a8633.tar.gz'</text></g><g id="g15"><text class="foreground" textLength="656" x="0">path is '/nix/store/yjz2v8kfk2jkzc0w7lh43hfmcafpqs33-ad9fc9f559e78a764aac20f669f23</text></g><g id="g16"><text class="foreground" textLength="152" x="0">cdd020cd943.tar.gz'</text></g></defs></svg>
|
<rect class="background" height="100%" width="100%" x="0" y="0"/><g display="none"><use y="0" xlink:href="#g1"/><use y="17" xlink:href="#g2"/><use y="34" xlink:href="#g3"/><use y="51" xlink:href="#g4"/><use y="68" xlink:href="#g5"/><use y="85" xlink:href="#g6"/><use y="102" xlink:href="#g7"/><use y="119" xlink:href="#g8"/><use y="136" xlink:href="#g9"/><use y="153" xlink:href="#g10"/><use y="170" xlink:href="#g11"/><use y="187" xlink:href="#g12"/><use y="204" xlink:href="#g13"/><use y="221" xlink:href="#g14"/><use y="238" xlink:href="#g15"/><use y="255" xlink:href="#g16"/><use y="272" xlink:href="#g17"/><use y="289" xlink:href="#g18"/><use y="306" xlink:href="#g19"/><use y="323" xlink:href="#g20"/><use y="340" xlink:href="#g21"/><use y="357" xlink:href="#g22"/><use y="374" xlink:href="#g23"/><use y="391" xlink:href="#g24"/><use y="408" xlink:href="#g25"/><rect class="foreground" height="17" width="8" x="0" y="425"/><use y="425" xlink:href="#g26"/><animate attributeName="display" begin="0ms; anim_last.end" dur="1000ms" from="inline" to="inline" id="anim_last"/></g><defs><g id="g1"><text class="foreground" textLength="216" x="0"> redirectCount = 10</text></g><g id="g2"><text class="foreground" textLength="376" x="0"> responseTimeout = ResponseTimeoutDefault</text></g><g id="g3"><text class="foreground" textLength="264" x="0"> requestVersion = HTTP/1.1</text></g><g id="g4"><text class="foreground" textLength="8" x="0">}</text></g><g id="g5"><text class="foreground" textLength="656" x="0"> (StatusCodeException (Response {responseStatus = Status {statusCode = 403, status</text></g><g id="g6"><text class="foreground" textLength="656" x="0">Message = "Forbidden"}, responseVersion = HTTP/1.1, responseHeaders = [("Date","Su</text></g><g id="g7"><text class="foreground" textLength="656" x="0">n, 09 Jun 2019 20:58:18 GMT"),("Content-Type","application/json; charset=utf-8"),(</text></g><g id="g8"><text class="foreground" textLength="656" x="0">"Transfer-Encoding","chunked"),("Server","GitHub.com"),("Status","403 Forbidden"),</text></g><g id="g9"><text class="foreground" textLength="656" x="0">("X-RateLimit-Limit","60"),("X-RateLimit-Remaining","0"),("X-RateLimit-Reset","156</text></g><g id="g10"><text class="foreground" textLength="656" x="0">0117498"),("X-GitHub-Media-Type","github.v3; param=preview"),("Access-Control-Expo</text></g><g id="g11"><text class="foreground" textLength="656" x="0">se-Headers","ETag, Link, Location, Retry-After, X-GitHub-OTP, X-RateLimit-Limit, X</text></g><g id="g12"><text class="foreground" textLength="656" x="0">-RateLimit-Remaining, X-RateLimit-Reset, X-OAuth-Scopes, X-Accepted-OAuth-Scopes, </text></g><g id="g13"><text class="foreground" textLength="656" x="0">X-Poll-Interval, X-GitHub-Media-Type"),("Access-Control-Allow-Origin","*"),("Stric</text></g><g id="g14"><text class="foreground" textLength="656" x="0">t-Transport-Security","max-age=31536000; includeSubdomains; preload"),("X-Frame-Op</text></g><g id="g15"><text class="foreground" textLength="656" x="0">tions","deny"),("X-Content-Type-Options","nosniff"),("X-XSS-Protection","1; mode=b</text></g><g id="g16"><text class="foreground" textLength="656" x="0">lock"),("Referrer-Policy","origin-when-cross-origin, strict-origin-when-cross-orig</text></g><g id="g17"><text class="foreground" textLength="656" x="0">in"),("Content-Security-Policy","default-src 'none'"),("Content-Encoding","gzip"),</text></g><g id="g18"><text class="foreground" textLength="656" x="0">("X-GitHub-Request-Id","5B88:5CE6:6ED9B59:8B00C6C:5CFD72EA")], responseBody = (), </text></g><g id="g19"><text class="foreground" textLength="656" x="0">responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}) "{\"message</text></g><g id="g20"><text class="foreground" textLength="656" x="0">\":\"API rate limit exceeded for 31.10.138.2. (But here's the good news: Authentic</text></g><g id="g21"><text class="foreground" textLength="656" x="0">ated requests get a higher rate limit. Check out the documentation for more detail</text></g><g id="g22"><text class="foreground" textLength="656" x="0">s.)\",\"documentation_url\":\"https://developer.github.com/v3/#rate-limiting\"}"))</text></g><g id="g23"><text class="foreground" textLength="240" x="0">CallStack (from HasCallStack):</text></g><g id="g24"><text class="foreground" textLength="656" x="0"> error, called at src/Niv/GitHub.hs:26:17 in niv-0.0.0-JC9JoLR1NiMAj6KwAyJn9X:Niv</text></g><g id="g25"><text class="foreground" textLength="56" x="0">.GitHub</text></g><g id="g26"><text class="background" textLength="8" x="0"> </text></g></defs></svg>
|
||||||
</svg>
|
</svg>
|
Before Width: | Height: | Size: 5.5 KiB After Width: | Height: | Size: 6.4 KiB |
97
src/Niv/GitHub.hs
Normal file
97
src/Niv/GitHub.hs
Normal file
@ -0,0 +1,97 @@
|
|||||||
|
{-# LANGUAGE Arrows #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Niv.GitHub where
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
import Data.Bool
|
||||||
|
import Data.Maybe
|
||||||
|
import GHC.Exts (toList)
|
||||||
|
import Niv.Update
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified GitHub as GH
|
||||||
|
import qualified GitHub.Data.Name as GH
|
||||||
|
|
||||||
|
data GithubRepo = GithubRepo
|
||||||
|
{ repoDescription :: Maybe T.Text
|
||||||
|
, repoHomepage :: Maybe T.Text
|
||||||
|
, repoDefaultBranch :: Maybe T.Text
|
||||||
|
}
|
||||||
|
|
||||||
|
githubRepo :: T.Text -> T.Text -> IO GithubRepo
|
||||||
|
githubRepo owner repo = fmap translate <$>
|
||||||
|
GH.executeRequest' (GH.repositoryR (GH.N owner) (GH.N repo)) >>= \case
|
||||||
|
Left e -> error (show e)
|
||||||
|
Right x -> pure x
|
||||||
|
where
|
||||||
|
translate r = GithubRepo
|
||||||
|
{ repoDescription = GH.repoDescription r
|
||||||
|
, repoHomepage = GH.repoHomepage r
|
||||||
|
, repoDefaultBranch = GH.repoDefaultBranch r
|
||||||
|
}
|
||||||
|
|
||||||
|
-- TODO: fetchers for:
|
||||||
|
-- * npm
|
||||||
|
-- * hackage
|
||||||
|
-- * docker
|
||||||
|
-- * ... ?
|
||||||
|
githubUpdate
|
||||||
|
:: (Bool -> T.Text -> IO T.Text)
|
||||||
|
-- ^ prefetch
|
||||||
|
-> (T.Text -> T.Text -> T.Text -> IO T.Text)
|
||||||
|
-- ^ latest revision
|
||||||
|
-> (T.Text -> T.Text -> IO GithubRepo)
|
||||||
|
-- ^ get repo
|
||||||
|
-> Update () ()
|
||||||
|
githubUpdate prefetch latestRev ghRepo = proc () -> do
|
||||||
|
urlTemplate <- template <<<
|
||||||
|
(useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -<
|
||||||
|
()
|
||||||
|
url <- update "url" -< urlTemplate
|
||||||
|
let isTar = ("tar.gz" `T.isSuffixOf`) <$> url
|
||||||
|
useOrSet "type" -< bool "file" "tarball" <$> isTar :: Box T.Text
|
||||||
|
let doUnpack = isTar
|
||||||
|
_sha256 <- update "sha256" <<< run (\(up, u) -> prefetch up u) -< (,) <$> doUnpack <*> url
|
||||||
|
returnA -< ()
|
||||||
|
where
|
||||||
|
completeSpec :: Update () (Box T.Text)
|
||||||
|
completeSpec = proc () -> do
|
||||||
|
owner <- load "owner" -< ()
|
||||||
|
repo <- load "repo" -< ()
|
||||||
|
repoInfo <- run (\(a, b) -> ghRepo a b) -< (,) <$> owner <*> repo
|
||||||
|
branch <- useOrSet "branch" <<< arr (fmap $ fromMaybe "master") -<
|
||||||
|
repoDefaultBranch <$> repoInfo
|
||||||
|
_description <- useOrSet "description" -< repoDescription <$> repoInfo
|
||||||
|
_homepage <- useOrSet "homepage" -< repoHomepage <$> repoInfo
|
||||||
|
_ <- update "rev" <<< run' (\(a,b,c) -> latestRev a b c) -<
|
||||||
|
(,,) <$> owner <*> repo <*> branch
|
||||||
|
returnA -< pure githubURLTemplate
|
||||||
|
|
||||||
|
githubURLTemplate :: T.Text
|
||||||
|
githubURLTemplate =
|
||||||
|
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||||
|
|
||||||
|
-- | Get the latest revision for owner, repo and branch.
|
||||||
|
-- TODO: explain no error handling
|
||||||
|
githubLatestRev
|
||||||
|
:: T.Text
|
||||||
|
-- ^ owner
|
||||||
|
-> T.Text
|
||||||
|
-- ^ repo
|
||||||
|
-> T.Text
|
||||||
|
-- ^ branch
|
||||||
|
-> IO T.Text
|
||||||
|
githubLatestRev owner repo branch =
|
||||||
|
GH.executeRequest' (
|
||||||
|
GH.commitsWithOptionsForR (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
|
||||||
|
[GH.CommitQuerySha branch]
|
||||||
|
) >>= \case
|
||||||
|
Right (toList -> (commit:_)) -> do
|
||||||
|
let GH.N rev = GH.commitSha commit
|
||||||
|
pure $ rev
|
||||||
|
Right (toList -> []) -> do
|
||||||
|
error "No rev: no commits"
|
||||||
|
Left e -> error $ "No rev: " <> show e
|
||||||
|
_ -> error $ "No rev: impossible"
|
136
src/Niv/GitHub/Test.hs
Normal file
136
src/Niv/GitHub/Test.hs
Normal file
@ -0,0 +1,136 @@
|
|||||||
|
{-# LANGUAGE Arrows #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Niv.GitHub.Test where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Niv.GitHub
|
||||||
|
import Niv.Update
|
||||||
|
import qualified Data.HashMap.Strict as HMS
|
||||||
|
|
||||||
|
test_githubInitsProperly :: IO ()
|
||||||
|
test_githubInitsProperly = do
|
||||||
|
actualState <- evalUpdate initialState $ proc () ->
|
||||||
|
githubUpdate prefetch latestRev ghRepo -< ()
|
||||||
|
unless ((snd <$> actualState) == expectedState) $
|
||||||
|
error $ "State mismatch: " <> show actualState
|
||||||
|
where
|
||||||
|
prefetch _ _ = pure "some-sha"
|
||||||
|
latestRev _ _ _ = pure "some-rev"
|
||||||
|
ghRepo _ _ = pure GithubRepo
|
||||||
|
{ repoDescription = Just "some-descr"
|
||||||
|
, repoHomepage = Just "some-homepage"
|
||||||
|
, repoDefaultBranch = Just "master"
|
||||||
|
}
|
||||||
|
initialState = HMS.fromList
|
||||||
|
[ ("owner", (Free, "nmattia"))
|
||||||
|
, ("repo", (Free, "niv")) ]
|
||||||
|
expectedState = HMS.fromList
|
||||||
|
[ ("owner", "nmattia")
|
||||||
|
, ("repo", "niv")
|
||||||
|
, ("homepage", "some-homepage")
|
||||||
|
, ("description", "some-descr")
|
||||||
|
, ("branch", "master")
|
||||||
|
, ("url", "https://github.com/nmattia/niv/archive/some-rev.tar.gz")
|
||||||
|
, ("rev", "some-rev")
|
||||||
|
, ("sha256", "some-sha")
|
||||||
|
, ("type", "tarball")
|
||||||
|
, ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
|
||||||
|
]
|
||||||
|
|
||||||
|
test_githubUpdates :: IO ()
|
||||||
|
test_githubUpdates = do
|
||||||
|
actualState <- evalUpdate initialState $ proc () ->
|
||||||
|
githubUpdate prefetch latestRev ghRepo -< ()
|
||||||
|
unless ((snd <$> actualState) == expectedState) $
|
||||||
|
error $ "State mismatch: " <> show actualState
|
||||||
|
where
|
||||||
|
prefetch _ _ = pure "new-sha"
|
||||||
|
latestRev _ _ _ = pure "new-rev"
|
||||||
|
ghRepo _ _ = pure GithubRepo
|
||||||
|
{ repoDescription = Just "some-descr"
|
||||||
|
, repoHomepage = Just "some-homepage"
|
||||||
|
, repoDefaultBranch = Just "master"
|
||||||
|
}
|
||||||
|
initialState = HMS.fromList
|
||||||
|
[ ("owner", (Free, "nmattia"))
|
||||||
|
, ("repo", (Free, "niv"))
|
||||||
|
, ("homepage", (Free, "some-homepage"))
|
||||||
|
, ("description", (Free, "some-descr"))
|
||||||
|
, ("branch", (Free, "master"))
|
||||||
|
, ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz"))
|
||||||
|
, ("rev", (Free, "some-rev"))
|
||||||
|
, ("sha256", (Free, "some-sha"))
|
||||||
|
, ("type", (Free, "tarball"))
|
||||||
|
, ("url_template", (Free, "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"))
|
||||||
|
]
|
||||||
|
expectedState = HMS.fromList
|
||||||
|
[ ("owner", "nmattia")
|
||||||
|
, ("repo", "niv")
|
||||||
|
, ("homepage", "some-homepage")
|
||||||
|
, ("description", "some-descr")
|
||||||
|
, ("branch", "master")
|
||||||
|
, ("url", "https://github.com/nmattia/niv/archive/new-rev.tar.gz")
|
||||||
|
, ("rev", "new-rev")
|
||||||
|
, ("sha256", "new-sha")
|
||||||
|
, ("type", "tarball")
|
||||||
|
, ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
|
||||||
|
]
|
||||||
|
|
||||||
|
test_githubDoesntOverrideRev :: IO ()
|
||||||
|
test_githubDoesntOverrideRev = do
|
||||||
|
actualState <- evalUpdate initialState $ proc () ->
|
||||||
|
githubUpdate prefetch latestRev ghRepo -< ()
|
||||||
|
unless ((snd <$> actualState) == expectedState) $
|
||||||
|
error $ "State mismatch: " <> show actualState
|
||||||
|
where
|
||||||
|
prefetch _ _ = pure "new-sha"
|
||||||
|
latestRev _ _ _ = error "shouldn't fetch rev"
|
||||||
|
ghRepo _ _ = error "shouldn't fetch repo"
|
||||||
|
initialState = HMS.fromList
|
||||||
|
[ ("owner", (Free, "nmattia"))
|
||||||
|
, ("repo", (Free, "niv"))
|
||||||
|
, ("homepage", (Free, "some-homepage"))
|
||||||
|
, ("description", (Free, "some-descr"))
|
||||||
|
, ("branch", (Free, "master"))
|
||||||
|
, ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz"))
|
||||||
|
, ("rev", (Locked, "custom-rev"))
|
||||||
|
, ("sha256", (Free, "some-sha"))
|
||||||
|
, ("type", (Free, "tarball"))
|
||||||
|
, ("url_template", (Free, "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"))
|
||||||
|
]
|
||||||
|
expectedState = HMS.fromList
|
||||||
|
[ ("owner", "nmattia")
|
||||||
|
, ("repo", "niv")
|
||||||
|
, ("homepage", "some-homepage")
|
||||||
|
, ("description", "some-descr")
|
||||||
|
, ("branch", "master")
|
||||||
|
, ("url", "https://github.com/nmattia/niv/archive/custom-rev.tar.gz")
|
||||||
|
, ("rev", "custom-rev")
|
||||||
|
, ("sha256", "new-sha")
|
||||||
|
, ("type", "tarball")
|
||||||
|
, ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
|
||||||
|
]
|
||||||
|
|
||||||
|
-- TODO: HMS diff for test output
|
||||||
|
test_githubURLFallback :: IO ()
|
||||||
|
test_githubURLFallback = do
|
||||||
|
actualState <- evalUpdate initialState $ proc () ->
|
||||||
|
githubUpdate prefetch latestRev ghRepo -< ()
|
||||||
|
unless ((snd <$> actualState) == expectedState) $
|
||||||
|
error $ "State mismatch: " <> show actualState
|
||||||
|
where
|
||||||
|
prefetch _ _ = pure "some-sha"
|
||||||
|
latestRev _ _ _ = error "shouldn't fetch rev"
|
||||||
|
ghRepo _ _ = error "shouldn't fetch repo"
|
||||||
|
initialState = HMS.fromList
|
||||||
|
[ ("url_template", (Free, "https://foo.com/<baz>.tar.gz"))
|
||||||
|
, ("baz", (Free, "tarball"))
|
||||||
|
]
|
||||||
|
expectedState = HMS.fromList
|
||||||
|
[ ("url_template", "https://foo.com/<baz>.tar.gz")
|
||||||
|
, ("baz", "tarball")
|
||||||
|
, ("url", "https://foo.com/tarball.tar.gz")
|
||||||
|
, ("sha256", "some-sha")
|
||||||
|
, ("type", "tarball")
|
||||||
|
]
|
26
src/Niv/Test.hs
Normal file
26
src/Niv/Test.hs
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
module Niv.Test (tests) where
|
||||||
|
|
||||||
|
import Niv.GitHub.Test
|
||||||
|
import Niv.Update.Test
|
||||||
|
import qualified Test.Tasty as Tasty
|
||||||
|
import qualified Test.Tasty.HUnit as Tasty
|
||||||
|
|
||||||
|
tests :: Tasty.TestTree
|
||||||
|
tests = Tasty.testGroup "niv"
|
||||||
|
[ Tasty.testGroup "update"
|
||||||
|
[ Tasty.testCase "simply runs" simplyRuns
|
||||||
|
, Tasty.testCase "picks first" picksFirst
|
||||||
|
, Tasty.testCase "loads" loads
|
||||||
|
, Tasty.testCase "survives checks" survivesChecks
|
||||||
|
, Tasty.testCase "isn't too eager" isNotTooEager
|
||||||
|
, Tasty.testCase "dirty forces update" dirtyForcesUpdate
|
||||||
|
, Tasty.testCase "should run when no changes" shouldNotRunWhenNoChanges
|
||||||
|
, Tasty.testCase "templates expand" templatesExpand
|
||||||
|
]
|
||||||
|
, Tasty.testGroup "github"
|
||||||
|
[ Tasty.testCase "inits properly" test_githubInitsProperly
|
||||||
|
, Tasty.testCase "updates" test_githubUpdates
|
||||||
|
, Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev
|
||||||
|
, Tasty.testCase "falls back to URL" test_githubURLFallback
|
||||||
|
]
|
||||||
|
]
|
269
src/Niv/Update.hs
Normal file
269
src/Niv/Update.hs
Normal file
@ -0,0 +1,269 @@
|
|||||||
|
{-# LANGUAGE Arrows #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
module Niv.Update where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Arrow
|
||||||
|
import Data.Aeson (FromJSON, ToJSON, Value)
|
||||||
|
import Data.String
|
||||||
|
import UnliftIO
|
||||||
|
import qualified Control.Category as Cat
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import qualified Data.HashMap.Strict as HMS
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
type JSON a = (ToJSON a, FromJSON a)
|
||||||
|
|
||||||
|
data UpdateFailed
|
||||||
|
= FailNoSuchKey T.Text
|
||||||
|
| FailBadIo SomeException
|
||||||
|
| FailZero
|
||||||
|
| FailCheck
|
||||||
|
| FailTemplate T.Text [T.Text]
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
data UpdateRes a b
|
||||||
|
= UpdateReady (UpdateReady b)
|
||||||
|
| UpdateNeedMore (a -> IO (UpdateReady b))
|
||||||
|
deriving Functor
|
||||||
|
|
||||||
|
data UpdateReady b
|
||||||
|
= UpdateSuccess BoxedAttrs b
|
||||||
|
| UpdateFailed UpdateFailed
|
||||||
|
deriving Functor
|
||||||
|
|
||||||
|
execUpdate :: Attrs -> Update () a -> IO a
|
||||||
|
execUpdate attrs a = snd <$> runUpdate attrs a
|
||||||
|
|
||||||
|
evalUpdate :: Attrs -> Update () a -> IO Attrs
|
||||||
|
evalUpdate attrs a = fst <$> runUpdate attrs a
|
||||||
|
|
||||||
|
runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
|
||||||
|
runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed
|
||||||
|
where
|
||||||
|
feed = \case
|
||||||
|
UpdateReady res -> hndl res
|
||||||
|
UpdateNeedMore next -> next (()) >>= hndl
|
||||||
|
hndl = \case
|
||||||
|
UpdateSuccess f v -> (,v) <$> unboxAttrs f
|
||||||
|
UpdateFailed e -> error $ "baaaah: " <> show e
|
||||||
|
|
||||||
|
runBox :: Box a -> IO a
|
||||||
|
runBox = boxOp
|
||||||
|
|
||||||
|
instance ArrowZero Update where
|
||||||
|
zeroArrow = Zero
|
||||||
|
|
||||||
|
instance ArrowPlus Update where
|
||||||
|
(<+>) = Plus
|
||||||
|
|
||||||
|
instance Arrow Update where
|
||||||
|
arr = Arr
|
||||||
|
first = First
|
||||||
|
|
||||||
|
data Update b c where
|
||||||
|
Id :: Update a a
|
||||||
|
Compose :: (Compose b c) -> Update b c
|
||||||
|
Arr :: (b -> c) -> Update b c
|
||||||
|
First :: Update b c -> Update (b, d) (c, d)
|
||||||
|
Zero :: Update b c
|
||||||
|
Plus :: Update b c -> Update b c -> Update b c
|
||||||
|
Check :: (a -> Bool) -> Update (Box a) ()
|
||||||
|
Load :: T.Text -> Update () (Box Value)
|
||||||
|
UseOrSet :: T.Text -> Update (Box Value) (Box Value)
|
||||||
|
Update :: T.Text -> Update (Box Value) (Box Value)
|
||||||
|
Run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||||
|
Template :: Update (Box T.Text) (Box T.Text)
|
||||||
|
|
||||||
|
instance Cat.Category Update where
|
||||||
|
id = Id
|
||||||
|
f . g = Compose (Compose' f g)
|
||||||
|
|
||||||
|
data Compose a c = forall b. Compose' (Update b c) (Update a b)
|
||||||
|
|
||||||
|
data Box a = Box
|
||||||
|
{ boxNew :: Bool
|
||||||
|
, boxOp :: IO a
|
||||||
|
}
|
||||||
|
deriving Functor
|
||||||
|
|
||||||
|
instance Applicative Box where
|
||||||
|
pure x = Box { boxNew = False, boxOp = pure x }
|
||||||
|
f <*> v = Box
|
||||||
|
{ boxNew = (||) (boxNew f) (boxNew v)
|
||||||
|
, boxOp = boxOp f <*> boxOp v
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Semigroup a => Semigroup (Box a) where
|
||||||
|
(<>) = liftA2 (<>)
|
||||||
|
|
||||||
|
instance IsString (Box T.Text) where
|
||||||
|
fromString str = Box { boxNew = False, boxOp = pure $ T.pack str }
|
||||||
|
|
||||||
|
instance Show (Update b c) where
|
||||||
|
show = \case
|
||||||
|
Id -> "Id"
|
||||||
|
Compose (Compose' f g)-> "(" <> show f <> " . " <> show g <> ")"
|
||||||
|
Arr _f -> "Arr"
|
||||||
|
First a -> "First " <> show a
|
||||||
|
Zero -> "Zero"
|
||||||
|
Plus l r -> "(" <> show l <> " + " <> show r <> ")"
|
||||||
|
Check _ch -> "Check"
|
||||||
|
Load k -> "Load " <> T.unpack k
|
||||||
|
UseOrSet k -> "UseOrSet " <> T.unpack k
|
||||||
|
Update k -> "Update " <> T.unpack k
|
||||||
|
Run _act -> "Io"
|
||||||
|
Template -> "Template"
|
||||||
|
|
||||||
|
type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value)
|
||||||
|
type Attrs = HMS.HashMap T.Text (Freedom, Value)
|
||||||
|
|
||||||
|
unboxAttrs :: BoxedAttrs -> IO Attrs
|
||||||
|
unboxAttrs = traverse (\(fr, v) -> (fr,) <$> runBox v)
|
||||||
|
|
||||||
|
boxAttrs :: Attrs -> BoxedAttrs
|
||||||
|
boxAttrs = fmap (\(fr, v) -> (fr,
|
||||||
|
case fr of
|
||||||
|
-- TODO: explain why hacky
|
||||||
|
Locked -> (pure v) { boxNew = True } -- XXX: somewhat hacky
|
||||||
|
Free -> pure v
|
||||||
|
))
|
||||||
|
|
||||||
|
data Freedom
|
||||||
|
= Locked
|
||||||
|
| Free
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- TODO: tryAny all IOs
|
||||||
|
runUpdate' :: BoxedAttrs -> Update a b -> IO (UpdateRes a b)
|
||||||
|
runUpdate' attrs = \case
|
||||||
|
Id -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs
|
||||||
|
Arr f -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs . f
|
||||||
|
Zero -> pure $ UpdateReady (UpdateFailed FailZero)
|
||||||
|
Plus l r -> runUpdate' attrs l >>= \case
|
||||||
|
UpdateReady (UpdateFailed{}) -> runUpdate' attrs r
|
||||||
|
UpdateReady (UpdateSuccess f v) -> pure $ UpdateReady (UpdateSuccess f v)
|
||||||
|
UpdateNeedMore next -> pure $ UpdateNeedMore $ \v -> next v >>= \case
|
||||||
|
UpdateSuccess f res -> pure $ UpdateSuccess f res
|
||||||
|
UpdateFailed {} -> runUpdate' attrs r >>= \case
|
||||||
|
UpdateReady res -> pure res
|
||||||
|
UpdateNeedMore next' -> next' v
|
||||||
|
Load k -> pure $ UpdateReady $ do
|
||||||
|
case HMS.lookup k attrs of
|
||||||
|
Just (_, v') -> UpdateSuccess attrs v'
|
||||||
|
Nothing -> UpdateFailed $ FailNoSuchKey k
|
||||||
|
First a -> do
|
||||||
|
runUpdate' attrs a >>= \case
|
||||||
|
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
|
||||||
|
UpdateReady (UpdateSuccess fo ba) -> pure $ UpdateNeedMore $ \gtt -> do
|
||||||
|
pure $ UpdateSuccess fo (ba, snd gtt)
|
||||||
|
UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do
|
||||||
|
next (fst gtt) >>= \case
|
||||||
|
UpdateFailed e -> pure $ UpdateFailed e
|
||||||
|
UpdateSuccess f res -> do
|
||||||
|
pure $ UpdateSuccess f (res, snd gtt)
|
||||||
|
Run act -> pure (UpdateNeedMore $ \gtt -> do
|
||||||
|
pure $ UpdateSuccess attrs $ Box (boxNew gtt) (act =<< runBox gtt))
|
||||||
|
Check ch -> pure (UpdateNeedMore $ \gtt -> do
|
||||||
|
v <- runBox gtt
|
||||||
|
if ch v
|
||||||
|
then pure $ UpdateSuccess attrs ()
|
||||||
|
else pure $ UpdateFailed FailCheck)
|
||||||
|
UseOrSet k -> pure $ case HMS.lookup k attrs of
|
||||||
|
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||||
|
Just (Free, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||||
|
Nothing -> UpdateNeedMore $ \gtt -> do
|
||||||
|
let attrs' = HMS.singleton k (Locked, gtt) <> attrs
|
||||||
|
pure $ UpdateSuccess attrs' gtt
|
||||||
|
Update k -> pure $ case HMS.lookup k attrs of
|
||||||
|
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||||
|
Just (Free, v) -> UpdateNeedMore $ \gtt -> do
|
||||||
|
if (boxNew gtt)
|
||||||
|
then pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt
|
||||||
|
else pure $ UpdateSuccess attrs v
|
||||||
|
Nothing -> UpdateNeedMore $ \gtt -> do
|
||||||
|
pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt
|
||||||
|
Compose (Compose' f g) -> runUpdate' attrs g >>= \case
|
||||||
|
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
|
||||||
|
UpdateReady (UpdateSuccess attrs' act) -> runUpdate' attrs' f >>= \case
|
||||||
|
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
|
||||||
|
UpdateReady (UpdateSuccess attrs'' act') -> pure $ UpdateReady $ UpdateSuccess attrs'' act'
|
||||||
|
UpdateNeedMore next -> UpdateReady <$> next act
|
||||||
|
UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do
|
||||||
|
next gtt >>= \case
|
||||||
|
UpdateFailed e -> pure $ UpdateFailed e
|
||||||
|
UpdateSuccess attrs' act -> runUpdate' attrs' f >>= \case
|
||||||
|
UpdateReady ready -> pure ready
|
||||||
|
UpdateNeedMore next' -> next' act
|
||||||
|
Template -> pure $ UpdateNeedMore $ \v -> do
|
||||||
|
v' <- runBox v
|
||||||
|
case renderTemplate (\k -> (decodeBox . snd) <$> HMS.lookup k attrs) v' of
|
||||||
|
Nothing -> pure $ UpdateFailed $ FailTemplate v' (HMS.keys attrs)
|
||||||
|
Just v'' -> pure $ UpdateSuccess attrs (v'' <* v) -- carries over v's newness
|
||||||
|
|
||||||
|
decodeBox :: FromJSON a => Box Value -> Box a
|
||||||
|
decodeBox v = v { boxOp = boxOp v >>= decodeValue }
|
||||||
|
|
||||||
|
decodeValue :: FromJSON a => Value -> IO a
|
||||||
|
decodeValue v = case Aeson.fromJSON v of
|
||||||
|
Aeson.Success x -> pure x
|
||||||
|
Aeson.Error str -> error $ "Could not decode: " <> show v <> " :" <> str
|
||||||
|
|
||||||
|
-- | Renders the template. Returns 'Nothing' if some of the attributes are
|
||||||
|
-- missing.
|
||||||
|
-- TODO: fix doc
|
||||||
|
-- renderTemplate [("foo", "bar")] "<foo>" == pure (Just "bar")
|
||||||
|
-- renderTemplate [("foo", "bar")] "<baz>" == pure Nothing
|
||||||
|
renderTemplate :: (T.Text -> Maybe (Box T.Text)) -> T.Text -> Maybe (Box T.Text)
|
||||||
|
renderTemplate vals = \case
|
||||||
|
(T.uncons -> Just ('<', str)) -> do
|
||||||
|
case T.span (/= '>') str of
|
||||||
|
(key, T.uncons -> Just ('>', rest)) -> do
|
||||||
|
let v = vals key
|
||||||
|
(liftA2 (<>) v) (renderTemplate vals rest)
|
||||||
|
_ -> Nothing
|
||||||
|
(T.uncons -> Just (c, str)) -> fmap (T.cons c) <$> renderTemplate vals str
|
||||||
|
(T.uncons -> Nothing) -> Just $ pure T.empty
|
||||||
|
-- XXX: isn't this redundant?
|
||||||
|
_ -> Just $ pure T.empty
|
||||||
|
|
||||||
|
|
||||||
|
template :: Update (Box T.Text) (Box T.Text)
|
||||||
|
template = Template
|
||||||
|
|
||||||
|
check :: (a -> Bool) -> Update (Box a) ()
|
||||||
|
check = Check
|
||||||
|
|
||||||
|
load :: FromJSON a => T.Text -> Update () (Box a)
|
||||||
|
load k = Load k >>> arr decodeBox
|
||||||
|
|
||||||
|
-- TODO: should input really be Box?
|
||||||
|
useOrSet :: JSON a => T.Text -> Update (Box a) (Box a)
|
||||||
|
useOrSet k =
|
||||||
|
arr (fmap Aeson.toJSON) >>>
|
||||||
|
UseOrSet k >>>
|
||||||
|
arr decodeBox
|
||||||
|
|
||||||
|
update :: JSON a => T.Text -> Update (Box a) (Box a)
|
||||||
|
update k =
|
||||||
|
arr (fmap Aeson.toJSON) >>>
|
||||||
|
Update k >>>
|
||||||
|
arr decodeBox
|
||||||
|
|
||||||
|
run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||||
|
run = Run
|
||||||
|
|
||||||
|
-- | Like 'run' but forces evaluation
|
||||||
|
run' :: (a -> IO b) -> Update (Box a) (Box b)
|
||||||
|
run' act = Run act >>> dirty
|
||||||
|
|
||||||
|
dirty :: Update (Box a) (Box a)
|
||||||
|
dirty = arr (\v -> v { boxNew = True })
|
114
src/Niv/Update/Test.hs
Normal file
114
src/Niv/Update/Test.hs
Normal file
@ -0,0 +1,114 @@
|
|||||||
|
{-# LANGUAGE Arrows #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Niv.Update.Test where
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
import Control.Monad
|
||||||
|
import Niv.Update
|
||||||
|
import qualified Data.HashMap.Strict as HMS
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
simplyRuns :: IO ()
|
||||||
|
simplyRuns =
|
||||||
|
void $ runUpdate attrs $ proc () -> do
|
||||||
|
returnA -< ()
|
||||||
|
where
|
||||||
|
attrs = HMS.empty
|
||||||
|
|
||||||
|
picksFirst :: IO ()
|
||||||
|
picksFirst = do
|
||||||
|
v <- execUpdate HMS.empty $
|
||||||
|
let
|
||||||
|
l = proc () -> do returnA -< 2
|
||||||
|
r = proc () -> do returnA -< 3
|
||||||
|
in l <+> r
|
||||||
|
unless (v == (2::Int)) (error "bad value")
|
||||||
|
|
||||||
|
loads :: IO ()
|
||||||
|
loads = do
|
||||||
|
v <- execUpdate attrs $ load "foo"
|
||||||
|
v' <- runBox v
|
||||||
|
unless (v' == ("bar" :: T.Text)) (error "bad value")
|
||||||
|
where
|
||||||
|
attrs = HMS.singleton "foo" (Locked, "bar")
|
||||||
|
|
||||||
|
survivesChecks :: IO ()
|
||||||
|
survivesChecks = do
|
||||||
|
v <- execUpdate attrs $ proc () -> do
|
||||||
|
(sawLeft <+> sawRight) -< ()
|
||||||
|
load "res" -< ()
|
||||||
|
v' <- runBox v
|
||||||
|
unless (v' == ("I saw right" :: T.Text)) (error "bad value")
|
||||||
|
where
|
||||||
|
attrs = HMS.singleton "val" (Locked, "right")
|
||||||
|
sawLeft :: Update () ()
|
||||||
|
sawLeft = proc () -> do
|
||||||
|
val <- load "val" -< ()
|
||||||
|
check (== "left") -< (val :: Box T.Text)
|
||||||
|
useOrSet "res" -< "I saw left" :: Box T.Text
|
||||||
|
returnA -< ()
|
||||||
|
sawRight :: Update () ()
|
||||||
|
sawRight = proc () -> do
|
||||||
|
val <- load "val" -< ()
|
||||||
|
check (== "right") -< (val :: Box T.Text)
|
||||||
|
useOrSet "res" -< "I saw right" :: Box T.Text
|
||||||
|
returnA -< ()
|
||||||
|
|
||||||
|
isNotTooEager :: IO ()
|
||||||
|
isNotTooEager = do
|
||||||
|
let f = constBox () >>>
|
||||||
|
run (const $ error "IO is too eager (f)") >>>
|
||||||
|
useOrSet "foo"
|
||||||
|
let f1 = proc () -> do
|
||||||
|
run (const $ error "IO is too eager (f1)") -< pure ()
|
||||||
|
useOrSet "foo" -< "foo"
|
||||||
|
void $ (execUpdate attrs f :: IO (Box T.Text))
|
||||||
|
void $ (execUpdate attrs f1 :: IO (Box T.Text))
|
||||||
|
where
|
||||||
|
attrs = HMS.singleton "foo" (Locked, "right")
|
||||||
|
|
||||||
|
dirtyForcesUpdate :: IO ()
|
||||||
|
dirtyForcesUpdate = do
|
||||||
|
let f = constBox ("world" :: T.Text) >>> dirty >>> update "hello"
|
||||||
|
attrs' <- evalUpdate attrs f
|
||||||
|
unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
|
||||||
|
error $ "bad value for hello: " <> show attrs'
|
||||||
|
where
|
||||||
|
attrs = HMS.singleton "hello" (Free, "foo")
|
||||||
|
|
||||||
|
shouldNotRunWhenNoChanges :: IO ()
|
||||||
|
shouldNotRunWhenNoChanges = do
|
||||||
|
let f = proc () -> do
|
||||||
|
update "hello" -< ("world" :: Box T.Text)
|
||||||
|
run (\() -> error "io shouldn't be run") -< pure ()
|
||||||
|
attrs <- evalUpdate HMS.empty f
|
||||||
|
unless ((snd <$> HMS.lookup "hello" attrs) == Just "world") $
|
||||||
|
error $ "bad value for hello: " <> show attrs
|
||||||
|
let f' = proc () -> do
|
||||||
|
run (\() -> error "io shouldn't be run") -< pure ()
|
||||||
|
update "hello" -< ("world" :: Box T.Text)
|
||||||
|
attrs' <- evalUpdate HMS.empty f'
|
||||||
|
unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
|
||||||
|
error $ "bad value for hello: " <> show attrs'
|
||||||
|
v3 <- execUpdate
|
||||||
|
(HMS.fromList [("hello", (Free, "world")), ("bar", (Free, "baz"))]) $
|
||||||
|
proc () -> do
|
||||||
|
v1 <- update "hello" -< "world"
|
||||||
|
v2 <- run (\_ -> error "io shouldn't be run") -< (v1 :: Box T.Text)
|
||||||
|
v3 <- update "bar" -< (v2 :: Box T.Text)
|
||||||
|
returnA -< v3
|
||||||
|
v3' <- runBox v3
|
||||||
|
unless (v3' == "baz") $ error "bad value"
|
||||||
|
|
||||||
|
templatesExpand :: IO ()
|
||||||
|
templatesExpand = do
|
||||||
|
v3 <- execUpdate attrs $ proc () -> template -< "<v1>-<v2>"
|
||||||
|
v3' <- runBox v3
|
||||||
|
unless (v3' == "hello-world") $ error "bad value"
|
||||||
|
where
|
||||||
|
attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))]
|
||||||
|
|
||||||
|
constBox :: a -> Update () (Box a)
|
||||||
|
constBox a = arr (const (pure a))
|
@ -22,8 +22,8 @@ let
|
|||||||
# TODO: Remove this patch by adding an argument to the github
|
# TODO: Remove this patch by adding an argument to the github
|
||||||
# subcommand to support GitHub entreprise.
|
# subcommand to support GitHub entreprise.
|
||||||
prePatch = ''
|
prePatch = ''
|
||||||
sed "s|GH.executeRequest'|GH.executeRequest (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i app/Niv.hs
|
sed "s|GH.executeRequest'|GH.executeRequest (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i src/Niv/GitHub.hs
|
||||||
sed "s|https://github.com|http://localhost:3333|" -i app/Niv.hs
|
sed "s|https://github.com|http://localhost:3333|" -i src/Niv/GitHub.hs
|
||||||
'';
|
'';
|
||||||
});
|
});
|
||||||
in pkgs.runCommand "test"
|
in pkgs.runCommand "test"
|
||||||
@ -75,7 +75,11 @@ in pkgs.runCommand "test"
|
|||||||
mock/NixOS/nixpkgs-channels/archive/${nixpkgs-channels_HEAD}.tar.gz
|
mock/NixOS/nixpkgs-channels/archive/${nixpkgs-channels_HEAD}.tar.gz
|
||||||
|
|
||||||
niv init
|
niv init
|
||||||
diff -h ${./expected/niv-init.json} nix/sources.json
|
diff -h ${./expected/niv-init.json} nix/sources.json || \
|
||||||
|
(echo "Mismatched sources.json"; \
|
||||||
|
echo "Reference: tests/expected/niv-init.json"; \
|
||||||
|
exit 1)
|
||||||
|
|
||||||
echo "*** ok."
|
echo "*** ok."
|
||||||
|
|
||||||
|
|
||||||
|
@ -1,5 +1,6 @@
|
|||||||
{
|
{
|
||||||
"nixpkgs": {
|
"nixpkgs": {
|
||||||
|
"homepage": null,
|
||||||
"url": "http://localhost:3333/NixOS/nixpkgs-channels/archive/571b40d3f50466d3e91c1e609d372de96d782793.tar.gz",
|
"url": "http://localhost:3333/NixOS/nixpkgs-channels/archive/571b40d3f50466d3e91c1e609d372de96d782793.tar.gz",
|
||||||
"owner": "NixOS",
|
"owner": "NixOS",
|
||||||
"branch": "nixos-18.09",
|
"branch": "nixos-18.09",
|
||||||
|
Loading…
Reference in New Issue
Block a user