mirror of
https://github.com/nmattia/niv.git
synced 2024-11-29 00:42:04 +03:00
Run Ormolu
This commit is contained in:
Nicolas Mattia
parent
1edb6856ad
commit
e0bfb5d007
@ -11,7 +11,8 @@ import qualified Data.ByteString.Lazy as BL
|
||||
encodeFilePretty :: (ToJSON a) => FilePath -> a -> IO ()
|
||||
encodeFilePretty fp = BL.writeFile fp . AesonPretty.encodePretty' config
|
||||
where
|
||||
config = AesonPretty.defConfig {
|
||||
AesonPretty.confTrailingNewline = True,
|
||||
AesonPretty.confCompare = compare
|
||||
}
|
||||
config =
|
||||
AesonPretty.defConfig
|
||||
{ AesonPretty.confTrailingNewline = True,
|
||||
AesonPretty.confCompare = compare
|
||||
}
|
||||
|
||||
@ -1,40 +1,39 @@
|
||||
|
||||
module Data.HashMap.Strict.Extended where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Hashable (Hashable)
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.Hashable (Hashable)
|
||||
|
||||
--- HashMap
|
||||
|
||||
forWithKeyM
|
||||
:: (Eq k, Hashable k, Monad m)
|
||||
=> HMS.HashMap k v1
|
||||
-> (k -> v1 -> m v2)
|
||||
-> m (HMS.HashMap k v2)
|
||||
forWithKeyM ::
|
||||
(Eq k, Hashable k, Monad m) =>
|
||||
HMS.HashMap k v1 ->
|
||||
(k -> v1 -> m v2) ->
|
||||
m (HMS.HashMap k v2)
|
||||
forWithKeyM = flip mapWithKeyM
|
||||
|
||||
forWithKeyM_
|
||||
:: (Eq k, Hashable k, Monad m)
|
||||
=> HMS.HashMap k v1
|
||||
-> (k -> v1 -> m ())
|
||||
-> m ()
|
||||
forWithKeyM_ ::
|
||||
(Eq k, Hashable k, Monad m) =>
|
||||
HMS.HashMap k v1 ->
|
||||
(k -> v1 -> m ()) ->
|
||||
m ()
|
||||
forWithKeyM_ = flip mapWithKeyM_
|
||||
|
||||
mapWithKeyM
|
||||
:: (Eq k, Hashable k, Monad m)
|
||||
=> (k -> v1 -> m v2)
|
||||
-> HMS.HashMap k v1
|
||||
-> m (HMS.HashMap k v2)
|
||||
mapWithKeyM ::
|
||||
(Eq k, Hashable k, Monad m) =>
|
||||
(k -> v1 -> m v2) ->
|
||||
HMS.HashMap k v1 ->
|
||||
m (HMS.HashMap k v2)
|
||||
mapWithKeyM f m = do
|
||||
fmap mconcat $ forM (HMS.toList m) $ \(k, v) ->
|
||||
HMS.singleton k <$> f k v
|
||||
fmap mconcat $ forM (HMS.toList m) $ \(k, v) ->
|
||||
HMS.singleton k <$> f k v
|
||||
|
||||
mapWithKeyM_
|
||||
:: (Eq k, Hashable k, Monad m)
|
||||
=> (k -> v1 -> m ())
|
||||
-> HMS.HashMap k v1
|
||||
-> m ()
|
||||
mapWithKeyM_ ::
|
||||
(Eq k, Hashable k, Monad m) =>
|
||||
(k -> v1 -> m ()) ->
|
||||
HMS.HashMap k v1 ->
|
||||
m ()
|
||||
mapWithKeyM_ f m = do
|
||||
forM_ (HMS.toList m) $ \(k, v) ->
|
||||
HMS.singleton k <$> f k v
|
||||
forM_ (HMS.toList m) $ \(k, v) ->
|
||||
HMS.singleton k <$> f k v
|
||||
|
||||
@ -2,10 +2,10 @@
|
||||
|
||||
module Data.Text.Extended where
|
||||
|
||||
import Niv.Logger
|
||||
import UnliftIO
|
||||
import System.Exit (exitFailure)
|
||||
import qualified Data.Text as T
|
||||
import Niv.Logger
|
||||
import System.Exit (exitFailure)
|
||||
import UnliftIO
|
||||
|
||||
tshow :: Show a => a -> T.Text
|
||||
tshow = T.pack . show
|
||||
@ -13,5 +13,5 @@ tshow = T.pack . show
|
||||
-- not quite the perfect place for this
|
||||
abort :: MonadIO io => T.Text -> io a
|
||||
abort msg = do
|
||||
tsay $ T.unwords [ tbold $ tred "FATAL:", msg ]
|
||||
liftIO exitFailure
|
||||
tsay $ T.unwords [tbold $ tred "FATAL:", msg]
|
||||
liftIO exitFailure
|
||||
|
||||
742
src/Niv/Cli.hs
742
src/Niv/Cli.hs
@ -12,34 +12,33 @@ import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import Data.Char (isSpace)
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.HashMap.Strict.Extended
|
||||
import Data.Hashable (Hashable)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Extended
|
||||
import Data.Version (showVersion)
|
||||
import Niv.Cmd
|
||||
import Niv.Git.Cmd
|
||||
import Niv.Local.Cmd
|
||||
import Niv.GitHub.Cmd
|
||||
import Niv.Local.Cmd
|
||||
import Niv.Logger
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import qualified Options.Applicative as Opts
|
||||
import qualified Options.Applicative.Help.Pretty as Opts
|
||||
-- I died a little
|
||||
import Paths_niv (version)
|
||||
import qualified System.Directory as Dir
|
||||
import System.Environment (getArgs)
|
||||
import System.FilePath (takeDirectory)
|
||||
import UnliftIO
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
import qualified Options.Applicative as Opts
|
||||
import qualified Options.Applicative.Help.Pretty as Opts
|
||||
import qualified System.Directory as Dir
|
||||
|
||||
-- I died a little
|
||||
import Paths_niv (version)
|
||||
|
||||
newtype NIO a = NIO { runNIO :: ReaderT FindSourcesJson IO a }
|
||||
newtype NIO a = NIO {runNIO :: ReaderT FindSourcesJson IO a}
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader FindSourcesJson)
|
||||
|
||||
instance MonadUnliftIO NIO where
|
||||
@ -53,42 +52,48 @@ li = liftIO
|
||||
|
||||
cli :: IO ()
|
||||
cli = do
|
||||
(fsj, nio) <- execParserPure' Opts.defaultPrefs opts <$> getArgs
|
||||
(fsj, nio) <-
|
||||
execParserPure' Opts.defaultPrefs opts <$> getArgs
|
||||
>>= Opts.handleParseResult
|
||||
runReaderT (runNIO nio) fsj
|
||||
runReaderT (runNIO nio) fsj
|
||||
where
|
||||
execParserPure' pprefs pinfo [] = Opts.Failure $
|
||||
Opts.parserFailure pprefs pinfo Opts.ShowHelpText mempty
|
||||
execParserPure' pprefs pinfo [] =
|
||||
Opts.Failure $
|
||||
Opts.parserFailure pprefs pinfo Opts.ShowHelpText mempty
|
||||
execParserPure' pprefs pinfo args = Opts.execParserPure pprefs pinfo args
|
||||
opts = Opts.info ((,) <$> parseFindSourcesJson <*> (parseCommand <**> Opts.helper)) $ mconcat desc
|
||||
desc =
|
||||
[ Opts.fullDesc
|
||||
, Opts.headerDoc $ Just $
|
||||
"niv - dependency manager for Nix projects" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
"version:" Opts.<+> Opts.text (showVersion version)
|
||||
[ Opts.fullDesc,
|
||||
Opts.headerDoc $ Just $
|
||||
"niv - dependency manager for Nix projects"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> "version:" Opts.<+> Opts.text (showVersion version)
|
||||
]
|
||||
parseFindSourcesJson =
|
||||
AtPath <$> Opts.strOption (
|
||||
Opts.long "sources-file" <>
|
||||
Opts.short 's' <>
|
||||
Opts.metavar "FILE" <>
|
||||
Opts.help "Use FILE instead of nix/sources.json"
|
||||
) <|> pure Auto
|
||||
|
||||
AtPath
|
||||
<$> Opts.strOption
|
||||
( Opts.long "sources-file"
|
||||
<> Opts.short 's'
|
||||
<> Opts.metavar "FILE"
|
||||
<> Opts.help "Use FILE instead of nix/sources.json"
|
||||
)
|
||||
<|> pure Auto
|
||||
|
||||
parseCommand :: Opts.Parser (NIO ())
|
||||
parseCommand = Opts.subparser (
|
||||
Opts.command "init" parseCmdInit <>
|
||||
Opts.command "add" parseCmdAdd <>
|
||||
Opts.command "show" parseCmdShow <>
|
||||
Opts.command "update" parseCmdUpdate <>
|
||||
Opts.command "modify" parseCmdModify <>
|
||||
Opts.command "drop" parseCmdDrop )
|
||||
parseCommand =
|
||||
Opts.subparser
|
||||
( Opts.command "init" parseCmdInit
|
||||
<> Opts.command "add" parseCmdAdd
|
||||
<> Opts.command "show" parseCmdShow
|
||||
<> Opts.command "update" parseCmdUpdate
|
||||
<> Opts.command "modify" parseCmdModify
|
||||
<> Opts.command "drop" parseCmdDrop
|
||||
)
|
||||
|
||||
parsePackageName :: Opts.Parser PackageName
|
||||
parsePackageName = PackageName <$>
|
||||
Opts.argument Opts.str (Opts.metavar "PACKAGE")
|
||||
parsePackageName =
|
||||
PackageName
|
||||
<$> Opts.argument Opts.str (Opts.metavar "PACKAGE")
|
||||
|
||||
parsePackage :: Opts.Parser (PackageName, PackageSpec)
|
||||
parsePackage = (,) <$> parsePackageName <*> (parsePackageSpec githubCmd)
|
||||
@ -120,95 +125,105 @@ parseCmdInit = Opts.info (cmdInit <$> parseNixpkgs <**> Opts.helper) $ mconcat d
|
||||
[owner, reponame] -> Just (Nixpkgs owner reponame)
|
||||
_ -> Nothing
|
||||
parseNixpkgs =
|
||||
Opts.flag' NoNixpkgs
|
||||
(
|
||||
Opts.long "no-nixpkgs" <>
|
||||
Opts.help "Don't add a nixpkgs entry to sources.json."
|
||||
) <|>
|
||||
(YesNixpkgs <$>
|
||||
(Opts.strOption
|
||||
(
|
||||
Opts.long "nixpkgs-branch" <>
|
||||
Opts.short 'b' <>
|
||||
Opts.help "The nixpkgs branch to use." <>
|
||||
Opts.showDefault <>
|
||||
Opts.value defaultNixpkgsBranch
|
||||
Opts.flag'
|
||||
NoNixpkgs
|
||||
( Opts.long "no-nixpkgs"
|
||||
<> Opts.help "Don't add a nixpkgs entry to sources.json."
|
||||
)
|
||||
) <*> Opts.option customNixpkgsReader
|
||||
(
|
||||
Opts.long "nixpkgs" <>
|
||||
Opts.showDefault <>
|
||||
Opts.help "Use a custom nixpkgs repository from GitHub." <>
|
||||
Opts.metavar "OWNER/REPO" <>
|
||||
Opts.value (Nixpkgs defaultNixpkgsUser defaultNixpkgsRepo)
|
||||
))
|
||||
<|> ( YesNixpkgs
|
||||
<$> ( Opts.strOption
|
||||
( Opts.long "nixpkgs-branch"
|
||||
<> Opts.short 'b'
|
||||
<> Opts.help "The nixpkgs branch to use."
|
||||
<> Opts.showDefault
|
||||
<> Opts.value defaultNixpkgsBranch
|
||||
)
|
||||
)
|
||||
<*> Opts.option
|
||||
customNixpkgsReader
|
||||
( Opts.long "nixpkgs"
|
||||
<> Opts.showDefault
|
||||
<> Opts.help "Use a custom nixpkgs repository from GitHub."
|
||||
<> Opts.metavar "OWNER/REPO"
|
||||
<> Opts.value (Nixpkgs defaultNixpkgsUser defaultNixpkgsRepo)
|
||||
)
|
||||
)
|
||||
desc =
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc
|
||||
"Initialize a Nix project. Existing files won't be modified."
|
||||
]
|
||||
|
||||
cmdInit :: FetchNixpkgs -> NIO ()
|
||||
cmdInit nixpkgs = do
|
||||
job "Initializing" $ do
|
||||
fsj <- getFindSourcesJson
|
||||
|
||||
-- Writes all the default files
|
||||
-- a path, a "create" function and an update function for each file.
|
||||
forM_
|
||||
[ ( pathNixSourcesNix
|
||||
, (`createFile` initNixSourcesNixContent)
|
||||
, \path content -> do
|
||||
if shouldUpdateNixSourcesNix content
|
||||
job "Initializing" $ do
|
||||
fsj <- getFindSourcesJson
|
||||
-- Writes all the default files
|
||||
-- a path, a "create" function and an update function for each file.
|
||||
forM_
|
||||
[ ( pathNixSourcesNix,
|
||||
(`createFile` initNixSourcesNixContent),
|
||||
\path content -> do
|
||||
if shouldUpdateNixSourcesNix content
|
||||
then do
|
||||
say "Updating sources.nix"
|
||||
li $ B.writeFile path initNixSourcesNixContent
|
||||
else say "Not updating sources.nix"
|
||||
)
|
||||
, ( pathNixSourcesJson fsj
|
||||
, \path -> do
|
||||
createFile path initNixSourcesJsonContent
|
||||
-- Imports @niv@ and @nixpkgs@
|
||||
say "Importing 'niv' ..."
|
||||
cmdAdd (updateCmd githubCmd) (PackageName "niv")
|
||||
(specToFreeAttrs $ PackageSpec $ HMS.fromList
|
||||
[ "owner" .= ("nmattia" :: T.Text)
|
||||
, "repo" .= ("niv" :: T.Text)
|
||||
]
|
||||
)
|
||||
case nixpkgs of
|
||||
NoNixpkgs -> say "Not importing 'nixpkgs'."
|
||||
YesNixpkgs branch nixpkgs' -> do
|
||||
say "Importing 'nixpkgs' ..."
|
||||
let (owner, repo) = case nixpkgs' of
|
||||
Nixpkgs o r -> (o,r)
|
||||
cmdAdd (updateCmd githubCmd) (PackageName "nixpkgs")
|
||||
(specToFreeAttrs $ PackageSpec $ HMS.fromList
|
||||
[ "owner" .= owner
|
||||
, "repo" .= repo
|
||||
, "branch" .= branch
|
||||
]
|
||||
)
|
||||
, \path _content -> dontCreateFile path)
|
||||
] $ \(path, onCreate, onUpdate) -> do
|
||||
exists <- li $ Dir.doesFileExist path
|
||||
if exists then li (B.readFile path) >>= onUpdate path else onCreate path
|
||||
case fsj of
|
||||
Auto -> pure ()
|
||||
AtPath fp ->
|
||||
tsay $ T.unlines
|
||||
),
|
||||
( pathNixSourcesJson fsj,
|
||||
\path -> do
|
||||
createFile path initNixSourcesJsonContent
|
||||
-- Imports @niv@ and @nixpkgs@
|
||||
say "Importing 'niv' ..."
|
||||
cmdAdd
|
||||
(updateCmd githubCmd)
|
||||
(PackageName "niv")
|
||||
( specToFreeAttrs $ PackageSpec $
|
||||
HMS.fromList
|
||||
[ "owner" .= ("nmattia" :: T.Text),
|
||||
"repo" .= ("niv" :: T.Text)
|
||||
]
|
||||
)
|
||||
case nixpkgs of
|
||||
NoNixpkgs -> say "Not importing 'nixpkgs'."
|
||||
YesNixpkgs branch nixpkgs' -> do
|
||||
say "Importing 'nixpkgs' ..."
|
||||
let (owner, repo) = case nixpkgs' of
|
||||
Nixpkgs o r -> (o, r)
|
||||
cmdAdd
|
||||
(updateCmd githubCmd)
|
||||
(PackageName "nixpkgs")
|
||||
( specToFreeAttrs $ PackageSpec $
|
||||
HMS.fromList
|
||||
[ "owner" .= owner,
|
||||
"repo" .= repo,
|
||||
"branch" .= branch
|
||||
]
|
||||
),
|
||||
\path _content -> dontCreateFile path
|
||||
)
|
||||
]
|
||||
$ \(path, onCreate, onUpdate) -> do
|
||||
exists <- li $ Dir.doesFileExist path
|
||||
if exists then li (B.readFile path) >>= onUpdate path else onCreate path
|
||||
case fsj of
|
||||
Auto -> pure ()
|
||||
AtPath fp ->
|
||||
tsay $
|
||||
T.unlines
|
||||
[ T.unwords
|
||||
[ tbold $ tblue "INFO:"
|
||||
, "You are using a custom path for sources.json."
|
||||
]
|
||||
, " You need to configure the sources.nix to use " <> tbold (T.pack fp) <> ":"
|
||||
, tbold " import sources.nix { sourcesFile = PATH ; }; "
|
||||
, T.unwords
|
||||
[ " where", tbold "PATH", "is the relative path from sources.nix to"
|
||||
, tbold (T.pack fp) <> "." ]
|
||||
[ tbold $ tblue "INFO:",
|
||||
"You are using a custom path for sources.json."
|
||||
],
|
||||
" You need to configure the sources.nix to use " <> tbold (T.pack fp) <> ":",
|
||||
tbold " import sources.nix { sourcesFile = PATH ; }; ",
|
||||
T.unwords
|
||||
[ " where",
|
||||
tbold "PATH",
|
||||
"is the relative path from sources.nix to",
|
||||
tbold (T.pack fp) <> "."
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
where
|
||||
createFile :: FilePath -> B.ByteString -> NIO ()
|
||||
createFile path content = li $ do
|
||||
@ -225,9 +240,9 @@ cmdInit nixpkgs = do
|
||||
|
||||
parseCmdAdd :: Opts.ParserInfo (NIO ())
|
||||
parseCmdAdd =
|
||||
Opts.info
|
||||
((parseCommands <|> parseShortcuts) <**> Opts.helper) $
|
||||
(description githubCmd)
|
||||
Opts.info
|
||||
((parseCommands <|> parseShortcuts) <**> Opts.helper)
|
||||
$ (description githubCmd)
|
||||
where
|
||||
-- XXX: this should parse many shortcuts (github, git). Right now we only
|
||||
-- parse GitHub because the git interface is still experimental. note to
|
||||
@ -242,12 +257,13 @@ parseCmdAdd =
|
||||
Opts.info (parseCmd localCmd <**> Opts.helper) (description localCmd)
|
||||
parseCmdAddGitHub =
|
||||
Opts.info (parseCmd githubCmd <**> Opts.helper) (description githubCmd)
|
||||
parseCommands = Opts.subparser
|
||||
( Opts.hidden <>
|
||||
Opts.commandGroup "Experimental commands:" <>
|
||||
Opts.command "git" parseCmdAddGit <>
|
||||
Opts.command "github" parseCmdAddGitHub <>
|
||||
Opts.command "local" parseCmdAddLocal
|
||||
parseCommands =
|
||||
Opts.subparser
|
||||
( Opts.hidden
|
||||
<> Opts.commandGroup "Experimental commands:"
|
||||
<> Opts.command "git" parseCmdAddGit
|
||||
<> Opts.command "github" parseCmdAddGitHub
|
||||
<> Opts.command "local" parseCmdAddLocal
|
||||
)
|
||||
|
||||
-- | only used in shortcuts (niv add foo/bar ...) because PACKAGE is NOT
|
||||
@ -261,17 +277,20 @@ parseShortcutArgs cmd = collapse <$> parseNameAndShortcut <*> parsePackageSpec c
|
||||
((_, spec), Just pname') -> (pname', PackageSpec spec)
|
||||
((pname', spec), Nothing) -> (pname', PackageSpec spec)
|
||||
parseNameAndShortcut =
|
||||
(,) <$>
|
||||
Opts.argument
|
||||
(,)
|
||||
<$> Opts.argument
|
||||
(Opts.maybeReader (parseCmdShortcut cmd . T.pack))
|
||||
(Opts.metavar "PACKAGE") <*>
|
||||
optName
|
||||
optName = Opts.optional $ PackageName <$> Opts.strOption
|
||||
( Opts.long "name" <>
|
||||
Opts.short 'n' <>
|
||||
Opts.metavar "NAME" <>
|
||||
Opts.help "Set the package name to <NAME>"
|
||||
)
|
||||
(Opts.metavar "PACKAGE")
|
||||
<*> optName
|
||||
optName =
|
||||
Opts.optional $
|
||||
PackageName
|
||||
<$> Opts.strOption
|
||||
( Opts.long "name"
|
||||
<> Opts.short 'n'
|
||||
<> Opts.metavar "NAME"
|
||||
<> Opts.help "Set the package name to <NAME>"
|
||||
)
|
||||
|
||||
-- | only used in command (niv add <cmd> ...) because PACKAGE is optional
|
||||
parseCmdArgs :: Cmd -> Opts.Parser (PackageName, Attrs)
|
||||
@ -285,35 +304,38 @@ parseCmdArgs cmd = collapse <$> parseNameAndShortcut <*> parsePackageSpec cmd
|
||||
(Nothing, Just pname') -> (pname', PackageSpec HMS.empty)
|
||||
(Nothing, Nothing) -> (PackageName "unnamed", PackageSpec HMS.empty)
|
||||
parseNameAndShortcut =
|
||||
(,) <$>
|
||||
Opts.optional (Opts.argument
|
||||
(Opts.maybeReader (parseCmdShortcut cmd . T.pack))
|
||||
(Opts.metavar "PACKAGE")) <*>
|
||||
optName
|
||||
optName = Opts.optional $ PackageName <$> Opts.strOption
|
||||
( Opts.long "name" <>
|
||||
Opts.short 'n' <>
|
||||
Opts.metavar "NAME" <>
|
||||
Opts.help "Set the package name to <NAME>"
|
||||
)
|
||||
(,)
|
||||
<$> Opts.optional
|
||||
( Opts.argument
|
||||
(Opts.maybeReader (parseCmdShortcut cmd . T.pack))
|
||||
(Opts.metavar "PACKAGE")
|
||||
)
|
||||
<*> optName
|
||||
optName =
|
||||
Opts.optional $
|
||||
PackageName
|
||||
<$> Opts.strOption
|
||||
( Opts.long "name"
|
||||
<> Opts.short 'n'
|
||||
<> Opts.metavar "NAME"
|
||||
<> Opts.help "Set the package name to <NAME>"
|
||||
)
|
||||
|
||||
cmdAdd :: Update () a -> PackageName -> Attrs -> NIO ()
|
||||
cmdAdd updateFunc packageName attrs = do
|
||||
job ("Adding package " <> T.unpack (unPackageName packageName)) $ do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
when (HMS.member packageName sources) $
|
||||
li $ abortCannotAddPackageExists packageName
|
||||
|
||||
eFinalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate attrs updateFunc)
|
||||
|
||||
case eFinalSpec of
|
||||
Left e -> li (abortUpdateFailed [(packageName, e)])
|
||||
Right finalSpec -> do
|
||||
say $ "Writing new sources file"
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.insert packageName finalSpec sources
|
||||
job ("Adding package " <> T.unpack (unPackageName packageName)) $ do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
when (HMS.member packageName sources)
|
||||
$ li
|
||||
$ abortCannotAddPackageExists packageName
|
||||
eFinalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate attrs updateFunc)
|
||||
case eFinalSpec of
|
||||
Left e -> li (abortUpdateFailed [(packageName, e)])
|
||||
Right finalSpec -> do
|
||||
say $ "Writing new sources file"
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.insert packageName finalSpec sources
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- SHOW
|
||||
@ -321,34 +343,32 @@ cmdAdd updateFunc packageName attrs = do
|
||||
|
||||
parseCmdShow :: Opts.ParserInfo (NIO ())
|
||||
parseCmdShow =
|
||||
Opts.info
|
||||
((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper)
|
||||
Opts.fullDesc
|
||||
Opts.info
|
||||
((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper)
|
||||
Opts.fullDesc
|
||||
|
||||
-- TODO: nicer output
|
||||
cmdShow :: Maybe PackageName -> NIO ()
|
||||
cmdShow = \case
|
||||
Just packageName -> do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
case HMS.lookup packageName sources of
|
||||
Just pspec -> showPackage packageName pspec
|
||||
Nothing -> li $ abortCannotShowNoSuchPackage packageName
|
||||
|
||||
Nothing -> do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
forWithKeyM_ sources $ showPackage
|
||||
Just packageName -> do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
case HMS.lookup packageName sources of
|
||||
Just pspec -> showPackage packageName pspec
|
||||
Nothing -> li $ abortCannotShowNoSuchPackage packageName
|
||||
Nothing -> do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
forWithKeyM_ sources $ showPackage
|
||||
|
||||
showPackage :: MonadIO io => PackageName -> PackageSpec -> io ()
|
||||
showPackage (PackageName pname) (PackageSpec spec) = do
|
||||
tsay $ tbold pname
|
||||
forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do
|
||||
let attrValue = case attrValValue of
|
||||
Aeson.String str -> str
|
||||
_ -> tfaint "<barabajagal>"
|
||||
tsay $ " " <> attrName <> ": " <> attrValue
|
||||
tsay $ tbold pname
|
||||
forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do
|
||||
let attrValue = case attrValValue of
|
||||
Aeson.String str -> str
|
||||
_ -> tfaint "<barabajagal>"
|
||||
tsay $ " " <> attrName <> ": " <> attrValue
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- UPDATE
|
||||
@ -356,21 +376,21 @@ showPackage (PackageName pname) (PackageSpec spec) = do
|
||||
|
||||
parseCmdUpdate :: Opts.ParserInfo (NIO ())
|
||||
parseCmdUpdate =
|
||||
Opts.info
|
||||
((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) $
|
||||
mconcat desc
|
||||
Opts.info
|
||||
((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper)
|
||||
$ mconcat desc
|
||||
where
|
||||
desc =
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Update dependencies"
|
||||
, Opts.headerDoc $ Just $ Opts.nest 2 $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
Opts.vcat
|
||||
[ Opts.fill 30 "niv update" Opts.<+> "# update all packages",
|
||||
Opts.fill 30 "niv update nixpkgs" Opts.<+> "# update nixpkgs",
|
||||
Opts.fill 30 "niv update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\""
|
||||
]
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc "Update dependencies",
|
||||
Opts.headerDoc $ Just $ Opts.nest 2 $
|
||||
"Examples:"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> Opts.vcat
|
||||
[ Opts.fill 30 "niv update" Opts.<+> "# update all packages",
|
||||
Opts.fill 30 "niv update nixpkgs" Opts.<+> "# update nixpkgs",
|
||||
Opts.fill 30 "niv update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\""
|
||||
]
|
||||
]
|
||||
|
||||
specToFreeAttrs :: PackageSpec -> Attrs
|
||||
@ -381,64 +401,65 @@ specToLockedAttrs = fmap (Locked,) . unPackageSpec
|
||||
|
||||
cmdUpdate :: Maybe (PackageName, PackageSpec) -> NIO ()
|
||||
cmdUpdate = \case
|
||||
Just (packageName, cliSpec) ->
|
||||
job ("Update " <> T.unpack (unPackageName packageName)) $ do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
eFinalSpec <- case HMS.lookup packageName sources of
|
||||
Just defaultSpec -> do
|
||||
-- lookup the "type" to find a Cmd to run, defaulting to legacy
|
||||
-- github
|
||||
let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of
|
||||
Just "git" -> gitCmd
|
||||
Just "local" -> localCmd
|
||||
_ -> githubCmd
|
||||
fmap attrsToSpec <$> li (tryEvalUpdate
|
||||
(specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)
|
||||
(updateCmd cmd))
|
||||
|
||||
Nothing -> li $ abortCannotUpdateNoSuchPackage packageName
|
||||
|
||||
case eFinalSpec of
|
||||
Left e -> li $ abortUpdateFailed [(packageName, e)]
|
||||
Right finalSpec ->
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.insert packageName finalSpec sources
|
||||
|
||||
Nothing -> job "Updating all packages" $ do
|
||||
Just (packageName, cliSpec) ->
|
||||
job ("Update " <> T.unpack (unPackageName packageName)) $ do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
esources' <- forWithKeyM sources $
|
||||
\packageName defaultSpec -> do
|
||||
tsay $ "Package: " <> unPackageName packageName
|
||||
let initialSpec = specToFreeAttrs defaultSpec
|
||||
eFinalSpec <- case HMS.lookup packageName sources of
|
||||
Just defaultSpec -> do
|
||||
-- lookup the "type" to find a Cmd to run, defaulting to legacy
|
||||
-- github
|
||||
let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of
|
||||
Just "git" -> gitCmd
|
||||
Just "local" -> localCmd
|
||||
_ -> githubCmd
|
||||
finalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate
|
||||
initialSpec
|
||||
(updateCmd cmd))
|
||||
pure finalSpec
|
||||
fmap attrsToSpec
|
||||
<$> li
|
||||
( tryEvalUpdate
|
||||
(specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)
|
||||
(updateCmd cmd)
|
||||
)
|
||||
Nothing -> li $ abortCannotUpdateNoSuchPackage packageName
|
||||
case eFinalSpec of
|
||||
Left e -> li $ abortUpdateFailed [(packageName, e)]
|
||||
Right finalSpec ->
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.insert packageName finalSpec sources
|
||||
Nothing -> job "Updating all packages" $ do
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
esources' <- forWithKeyM sources $
|
||||
\packageName defaultSpec -> do
|
||||
tsay $ "Package: " <> unPackageName packageName
|
||||
let initialSpec = specToFreeAttrs defaultSpec
|
||||
-- lookup the "type" to find a Cmd to run, defaulting to legacy
|
||||
-- github
|
||||
let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of
|
||||
Just "git" -> gitCmd
|
||||
Just "local" -> localCmd
|
||||
_ -> githubCmd
|
||||
finalSpec <-
|
||||
fmap attrsToSpec
|
||||
<$> li
|
||||
( tryEvalUpdate
|
||||
initialSpec
|
||||
(updateCmd cmd)
|
||||
)
|
||||
pure finalSpec
|
||||
let (failed, sources') = partitionEithersHMS esources'
|
||||
unless (HMS.null failed)
|
||||
$ li
|
||||
$ abortUpdateFailed (HMS.toList failed)
|
||||
li $ setSources fsj $ Sources sources'
|
||||
|
||||
let (failed, sources') = partitionEithersHMS esources'
|
||||
|
||||
unless (HMS.null failed) $
|
||||
li $ abortUpdateFailed (HMS.toList failed)
|
||||
|
||||
li $ setSources fsj $ Sources sources'
|
||||
|
||||
partitionEithersHMS
|
||||
:: (Eq k, Hashable k)
|
||||
=> HMS.HashMap k (Either a b) -> (HMS.HashMap k a, HMS.HashMap k b)
|
||||
partitionEithersHMS ::
|
||||
(Eq k, Hashable k) =>
|
||||
HMS.HashMap k (Either a b) ->
|
||||
(HMS.HashMap k a, HMS.HashMap k b)
|
||||
partitionEithersHMS =
|
||||
flip HMS.foldlWithKey' (HMS.empty, HMS.empty) $ \(ls, rs) k -> \case
|
||||
Left l -> (HMS.insert k l ls, rs)
|
||||
Right r -> (ls, HMS.insert k r rs)
|
||||
flip HMS.foldlWithKey' (HMS.empty, HMS.empty) $ \(ls, rs) k -> \case
|
||||
Left l -> (HMS.insert k l ls, rs)
|
||||
Right r -> (ls, HMS.insert k r rs)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- MODIFY
|
||||
@ -446,43 +467,45 @@ partitionEithersHMS =
|
||||
|
||||
parseCmdModify :: Opts.ParserInfo (NIO ())
|
||||
parseCmdModify =
|
||||
Opts.info
|
||||
((cmdModify <$> parsePackageName <*> optName <*> parsePackageSpec githubCmd) <**> Opts.helper) $
|
||||
mconcat desc
|
||||
Opts.info
|
||||
((cmdModify <$> parsePackageName <*> optName <*> parsePackageSpec githubCmd) <**> Opts.helper)
|
||||
$ mconcat desc
|
||||
where
|
||||
desc =
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Modify dependency attributes without performing an update"
|
||||
, Opts.headerDoc $ Just $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
" niv modify nixpkgs -v beta-0.2" Opts.<$$>
|
||||
" niv modify nixpkgs -a branch=nixpkgs-unstable"
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc "Modify dependency attributes without performing an update",
|
||||
Opts.headerDoc $ Just $
|
||||
"Examples:"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> " niv modify nixpkgs -v beta-0.2"
|
||||
Opts.<$$> " niv modify nixpkgs -a branch=nixpkgs-unstable"
|
||||
]
|
||||
optName = Opts.optional $ PackageName <$> Opts.strOption
|
||||
( Opts.long "name" <>
|
||||
Opts.short 'n' <>
|
||||
Opts.metavar "NAME" <>
|
||||
Opts.help "Set the package name to <NAME>"
|
||||
)
|
||||
optName =
|
||||
Opts.optional $
|
||||
PackageName
|
||||
<$> Opts.strOption
|
||||
( Opts.long "name"
|
||||
<> Opts.short 'n'
|
||||
<> Opts.metavar "NAME"
|
||||
<> Opts.help "Set the package name to <NAME>"
|
||||
)
|
||||
|
||||
cmdModify :: PackageName -> Maybe PackageName -> PackageSpec -> NIO ()
|
||||
cmdModify packageName mNewName cliSpec = do
|
||||
tsay $ "Modifying package: " <> unPackageName packageName
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
finalSpec <- case HMS.lookup packageName sources of
|
||||
Just defaultSpec -> pure $ attrsToSpec (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)
|
||||
Nothing -> li $ abortCannotModifyNoSuchPackage packageName
|
||||
|
||||
case mNewName of
|
||||
Just newName -> do
|
||||
when (HMS.member newName sources) $
|
||||
li $ abortCannotAddPackageExists newName
|
||||
li $ setSources fsj $ Sources $ HMS.insert newName finalSpec $ HMS.delete packageName sources
|
||||
Nothing ->
|
||||
li $ setSources fsj $ Sources $ HMS.insert packageName finalSpec sources
|
||||
tsay $ "Modifying package: " <> unPackageName packageName
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
finalSpec <- case HMS.lookup packageName sources of
|
||||
Just defaultSpec -> pure $ attrsToSpec (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)
|
||||
Nothing -> li $ abortCannotModifyNoSuchPackage packageName
|
||||
case mNewName of
|
||||
Just newName -> do
|
||||
when (HMS.member newName sources)
|
||||
$ li
|
||||
$ abortCannotAddPackageExists newName
|
||||
li $ setSources fsj $ Sources $ HMS.insert newName finalSpec $ HMS.delete packageName sources
|
||||
Nothing ->
|
||||
li $ setSources fsj $ Sources $ HMS.insert packageName finalSpec sources
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- DROP
|
||||
@ -490,51 +513,52 @@ cmdModify packageName mNewName cliSpec = do
|
||||
|
||||
parseCmdDrop :: Opts.ParserInfo (NIO ())
|
||||
parseCmdDrop =
|
||||
Opts.info
|
||||
((cmdDrop <$> parsePackageName <*> parseDropAttributes) <**>
|
||||
Opts.helper) $
|
||||
mconcat desc
|
||||
Opts.info
|
||||
( (cmdDrop <$> parsePackageName <*> parseDropAttributes)
|
||||
<**> Opts.helper
|
||||
)
|
||||
$ mconcat desc
|
||||
where
|
||||
desc =
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Drop dependency"
|
||||
, Opts.headerDoc $ Just $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
" niv drop jq" Opts.<$$>
|
||||
" niv drop my-package version"
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc "Drop dependency",
|
||||
Opts.headerDoc $ Just $
|
||||
"Examples:"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> " niv drop jq"
|
||||
Opts.<$$> " niv drop my-package version"
|
||||
]
|
||||
parseDropAttributes :: Opts.Parser [T.Text]
|
||||
parseDropAttributes = many $
|
||||
Opts.argument Opts.str (Opts.metavar "ATTRIBUTE")
|
||||
parseDropAttributes =
|
||||
many $
|
||||
Opts.argument Opts.str (Opts.metavar "ATTRIBUTE")
|
||||
|
||||
cmdDrop :: PackageName -> [T.Text] -> NIO ()
|
||||
cmdDrop packageName = \case
|
||||
[] -> do
|
||||
tsay $ "Dropping package: " <> unPackageName packageName
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
when (not $ HMS.member packageName sources) $
|
||||
li $ abortCannotDropNoSuchPackage packageName
|
||||
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.delete packageName sources
|
||||
attrs -> do
|
||||
tsay $ "Dropping attributes: " <> T.intercalate " " attrs
|
||||
tsay $ "In package: " <> unPackageName packageName
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
|
||||
packageSpec <- case HMS.lookup packageName sources of
|
||||
Nothing ->
|
||||
li $ abortCannotAttributesDropNoSuchPackage packageName
|
||||
Just (PackageSpec packageSpec) -> pure $ PackageSpec $
|
||||
[] -> do
|
||||
tsay $ "Dropping package: " <> unPackageName packageName
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
when (not $ HMS.member packageName sources)
|
||||
$ li
|
||||
$ abortCannotDropNoSuchPackage packageName
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.delete packageName sources
|
||||
attrs -> do
|
||||
tsay $ "Dropping attributes: " <> T.intercalate " " attrs
|
||||
tsay $ "In package: " <> unPackageName packageName
|
||||
fsj <- getFindSourcesJson
|
||||
sources <- unSources <$> li (getSources fsj)
|
||||
packageSpec <- case HMS.lookup packageName sources of
|
||||
Nothing ->
|
||||
li $ abortCannotAttributesDropNoSuchPackage packageName
|
||||
Just (PackageSpec packageSpec) ->
|
||||
pure $ PackageSpec $
|
||||
HMS.mapMaybeWithKey
|
||||
(\k v -> if k `elem` attrs then Nothing else Just v) packageSpec
|
||||
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.insert packageName packageSpec sources
|
||||
(\k v -> if k `elem` attrs then Nothing else Just v)
|
||||
packageSpec
|
||||
li $ setSources fsj $ Sources $
|
||||
HMS.insert packageName packageSpec sources
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Files and their content
|
||||
@ -544,15 +568,15 @@ cmdDrop packageName = \case
|
||||
-- a comment line with @niv: no_update@
|
||||
shouldUpdateNixSourcesNix :: B.ByteString -> Bool
|
||||
shouldUpdateNixSourcesNix content =
|
||||
content /= initNixSourcesNixContent &&
|
||||
not (any lineForbids (B8.lines content))
|
||||
content /= initNixSourcesNixContent
|
||||
&& not (any lineForbids (B8.lines content))
|
||||
where
|
||||
lineForbids :: B8.ByteString -> Bool
|
||||
lineForbids str =
|
||||
case B8.uncons (B8.dropWhile isSpace str) of
|
||||
Just ('#',rest) -> case B8.stripPrefix "niv:" (B8.dropWhile isSpace rest) of
|
||||
Just ('#', rest) -> case B8.stripPrefix "niv:" (B8.dropWhile isSpace rest) of
|
||||
Just rest' -> case B8.stripPrefix "no_update" (B8.dropWhile isSpace rest') of
|
||||
Just{} -> True
|
||||
Just {} -> True
|
||||
_ -> False
|
||||
_ -> False
|
||||
_ -> False
|
||||
@ -562,53 +586,67 @@ shouldUpdateNixSourcesNix content =
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
abortCannotAddPackageExists :: PackageName -> IO a
|
||||
abortCannotAddPackageExists (PackageName n) = abort $ T.unlines
|
||||
[ "Cannot add package " <> n <> "."
|
||||
, "The package already exists. Use"
|
||||
, " niv drop " <> n
|
||||
, "and then re-add the package. Alternatively use"
|
||||
, " niv update " <> n <> " --attribute foo=bar"
|
||||
, "to update the package's attributes."
|
||||
]
|
||||
abortCannotAddPackageExists (PackageName n) =
|
||||
abort $
|
||||
T.unlines
|
||||
[ "Cannot add package " <> n <> ".",
|
||||
"The package already exists. Use",
|
||||
" niv drop " <> n,
|
||||
"and then re-add the package. Alternatively use",
|
||||
" niv update " <> n <> " --attribute foo=bar",
|
||||
"to update the package's attributes."
|
||||
]
|
||||
|
||||
abortCannotUpdateNoSuchPackage :: PackageName -> IO a
|
||||
abortCannotUpdateNoSuchPackage (PackageName n) = abort $ T.unlines
|
||||
[ "Cannot update package " <> n <> "."
|
||||
, "The package doesn't exist. Use"
|
||||
, " niv add " <> n
|
||||
, "to add the package."
|
||||
]
|
||||
abortCannotUpdateNoSuchPackage (PackageName n) =
|
||||
abort $
|
||||
T.unlines
|
||||
[ "Cannot update package " <> n <> ".",
|
||||
"The package doesn't exist. Use",
|
||||
" niv add " <> n,
|
||||
"to add the package."
|
||||
]
|
||||
|
||||
abortCannotModifyNoSuchPackage :: PackageName -> IO a
|
||||
abortCannotModifyNoSuchPackage (PackageName n) = abort $ T.unlines
|
||||
[ "Cannot modify package " <> n <> "."
|
||||
, "The package doesn't exist. Use"
|
||||
, " niv add " <> n
|
||||
, "to add the package."
|
||||
]
|
||||
abortCannotModifyNoSuchPackage (PackageName n) =
|
||||
abort $
|
||||
T.unlines
|
||||
[ "Cannot modify package " <> n <> ".",
|
||||
"The package doesn't exist. Use",
|
||||
" niv add " <> n,
|
||||
"to add the package."
|
||||
]
|
||||
|
||||
abortCannotDropNoSuchPackage :: PackageName -> IO a
|
||||
abortCannotDropNoSuchPackage (PackageName n) = abort $ T.unlines
|
||||
[ "Cannot drop package " <> n <> "."
|
||||
, "The package doesn't exist."
|
||||
]
|
||||
abortCannotDropNoSuchPackage (PackageName n) =
|
||||
abort $
|
||||
T.unlines
|
||||
[ "Cannot drop package " <> n <> ".",
|
||||
"The package doesn't exist."
|
||||
]
|
||||
|
||||
abortCannotShowNoSuchPackage :: PackageName -> IO a
|
||||
abortCannotShowNoSuchPackage (PackageName n) = abort $ T.unlines
|
||||
[ "Cannot show package " <> n <> "."
|
||||
, "The package doesn't exist."
|
||||
]
|
||||
abortCannotShowNoSuchPackage (PackageName n) =
|
||||
abort $
|
||||
T.unlines
|
||||
[ "Cannot show package " <> n <> ".",
|
||||
"The package doesn't exist."
|
||||
]
|
||||
|
||||
abortCannotAttributesDropNoSuchPackage :: PackageName -> IO a
|
||||
abortCannotAttributesDropNoSuchPackage (PackageName n) = abort $ T.unlines
|
||||
[ "Cannot drop attributes of package " <> n <> "."
|
||||
, "The package doesn't exist."
|
||||
]
|
||||
|
||||
abortUpdateFailed :: [ (PackageName, SomeException) ] -> IO a
|
||||
abortUpdateFailed errs = abort $ T.unlines $
|
||||
[ "One or more packages failed to update:" ] <>
|
||||
map (\(PackageName pname, e) ->
|
||||
pname <> ": " <> tshow e
|
||||
) errs
|
||||
abortCannotAttributesDropNoSuchPackage (PackageName n) =
|
||||
abort $
|
||||
T.unlines
|
||||
[ "Cannot drop attributes of package " <> n <> ".",
|
||||
"The package doesn't exist."
|
||||
]
|
||||
|
||||
abortUpdateFailed :: [(PackageName, SomeException)] -> IO a
|
||||
abortUpdateFailed errs =
|
||||
abort $ T.unlines $
|
||||
["One or more packages failed to update:"]
|
||||
<> map
|
||||
( \(PackageName pname, e) ->
|
||||
pname <> ": " <> tshow e
|
||||
)
|
||||
errs
|
||||
|
||||
@ -2,17 +2,18 @@
|
||||
|
||||
module Niv.Cmd where
|
||||
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Text as T
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import qualified Options.Applicative as Opts
|
||||
|
||||
-- TODO: add filter
|
||||
data Cmd = Cmd
|
||||
{ description :: forall a. Opts.InfoMod a
|
||||
, parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
|
||||
, parsePackageSpec :: Opts.Parser PackageSpec
|
||||
, updateCmd :: Update () ()
|
||||
, name :: T.Text
|
||||
}
|
||||
data Cmd
|
||||
= Cmd
|
||||
{ description :: forall a. Opts.InfoMod a,
|
||||
parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object),
|
||||
parsePackageSpec :: Opts.Parser PackageSpec,
|
||||
updateCmd :: Update () (),
|
||||
name :: T.Text
|
||||
}
|
||||
|
||||
@ -1,42 +1,43 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Niv.Git.Cmd where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Extended as T
|
||||
import Niv.Cmd
|
||||
import Niv.Logger
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import System.Exit (ExitCode(ExitSuccess))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
import qualified Options.Applicative as Opts
|
||||
import qualified Options.Applicative.Help.Pretty as Opts
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
|
||||
gitCmd :: Cmd
|
||||
gitCmd = Cmd
|
||||
{ description = describeGit
|
||||
, parseCmdShortcut = parseGitShortcut
|
||||
, parsePackageSpec = parseGitPackageSpec
|
||||
, updateCmd = gitUpdate'
|
||||
, name = "git"
|
||||
}
|
||||
gitCmd =
|
||||
Cmd
|
||||
{ description = describeGit,
|
||||
parseCmdShortcut = parseGitShortcut,
|
||||
parsePackageSpec = parseGitPackageSpec,
|
||||
updateCmd = gitUpdate',
|
||||
name = "git"
|
||||
}
|
||||
|
||||
parseGitShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
|
||||
parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =
|
||||
-- basic heuristics for figuring out if something is a git repo
|
||||
if isGitURL
|
||||
-- basic heuristics for figuring out if something is a git repo
|
||||
if isGitURL
|
||||
then case T.splitOn "/" txt of
|
||||
[] -> Nothing
|
||||
(last -> w) -> case T.stripSuffix ".git" w of
|
||||
@ -45,77 +46,85 @@ parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =
|
||||
else Nothing
|
||||
where
|
||||
isGitURL =
|
||||
".git" `T.isSuffixOf` txt ||
|
||||
"git@" `T.isPrefixOf` txt ||
|
||||
"ssh://" `T.isPrefixOf` txt
|
||||
".git" `T.isSuffixOf` txt
|
||||
|| "git@" `T.isPrefixOf` txt
|
||||
|| "ssh://" `T.isPrefixOf` txt
|
||||
|
||||
parseGitPackageSpec :: Opts.Parser PackageSpec
|
||||
parseGitPackageSpec =
|
||||
(PackageSpec . HMS.fromList) <$>
|
||||
many (parseRepo <|> parseRef <|> parseRev <|> parseAttr <|> parseSAttr)
|
||||
(PackageSpec . HMS.fromList)
|
||||
<$> many (parseRepo <|> parseRef <|> parseRev <|> parseAttr <|> parseSAttr)
|
||||
where
|
||||
parseRepo =
|
||||
("repo", ) . Aeson.String <$> Opts.strOption
|
||||
( Opts.long "repo" <>
|
||||
Opts.metavar "URL"
|
||||
)
|
||||
("repo",) . Aeson.String
|
||||
<$> Opts.strOption
|
||||
( Opts.long "repo"
|
||||
<> Opts.metavar "URL"
|
||||
)
|
||||
parseRev =
|
||||
("rev", ) . Aeson.String <$> Opts.strOption
|
||||
( Opts.long "rev" <>
|
||||
Opts.metavar "SHA"
|
||||
)
|
||||
("rev",) . Aeson.String
|
||||
<$> Opts.strOption
|
||||
( Opts.long "rev"
|
||||
<> Opts.metavar "SHA"
|
||||
)
|
||||
parseRef =
|
||||
("ref", ) . Aeson.String <$> Opts.strOption
|
||||
( Opts.long "ref" <>
|
||||
Opts.metavar "REF"
|
||||
)
|
||||
("ref",) . Aeson.String
|
||||
<$> Opts.strOption
|
||||
( Opts.long "ref"
|
||||
<> Opts.metavar "REF"
|
||||
)
|
||||
parseAttr =
|
||||
Opts.option (Opts.maybeReader parseKeyValJSON)
|
||||
( Opts.long "attribute" <>
|
||||
Opts.short 'a' <>
|
||||
Opts.metavar "KEY=VAL" <>
|
||||
Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."
|
||||
Opts.option
|
||||
(Opts.maybeReader parseKeyValJSON)
|
||||
( Opts.long "attribute"
|
||||
<> Opts.short 'a'
|
||||
<> Opts.metavar "KEY=VAL"
|
||||
<> Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."
|
||||
)
|
||||
parseSAttr =
|
||||
Opts.option (Opts.maybeReader (parseKeyVal Aeson.toJSON))
|
||||
( Opts.long "string-attribute" <>
|
||||
Opts.short 's' <>
|
||||
Opts.metavar "KEY=VAL" <>
|
||||
Opts.help "Set the package spec attribute <KEY> to <VAL>."
|
||||
Opts.option
|
||||
(Opts.maybeReader (parseKeyVal Aeson.toJSON))
|
||||
( Opts.long "string-attribute"
|
||||
<> Opts.short 's'
|
||||
<> Opts.metavar "KEY=VAL"
|
||||
<> Opts.help "Set the package spec attribute <KEY> to <VAL>."
|
||||
)
|
||||
|
||||
parseKeyValJSON = parseKeyVal $ \x ->
|
||||
fromMaybe (Aeson.toJSON x) (Aeson.decodeStrict (B8.pack x))
|
||||
|
||||
-- Parse "key=val" into ("key", val)
|
||||
parseKeyVal
|
||||
:: (String -> Aeson.Value) -- ^ how to convert to JSON
|
||||
-> String -> Maybe (T.Text, Aeson.Value)
|
||||
parseKeyVal ::
|
||||
-- | how to convert to JSON
|
||||
(String -> Aeson.Value) ->
|
||||
String ->
|
||||
Maybe (T.Text, Aeson.Value)
|
||||
parseKeyVal toJSON str = case span (/= '=') str of
|
||||
(key, '=':val) -> Just (T.pack key, toJSON val)
|
||||
(key, '=' : val) -> Just (T.pack key, toJSON val)
|
||||
_ -> Nothing
|
||||
|
||||
describeGit :: Opts.InfoMod a
|
||||
describeGit = mconcat
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Add a git dependency. Experimental."
|
||||
, Opts.headerDoc $ Just $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
" niv add git git@github.com:stedolan/jq" Opts.<$$>
|
||||
" niv add git ssh://git@github.com/stedolan/jq --rev deadb33f" Opts.<$$>
|
||||
" niv add git https://github.com/stedolan/jq.git" Opts.<$$>
|
||||
" niv add git --repo /my/custom/repo --name custom --ref foobar"
|
||||
]
|
||||
describeGit =
|
||||
mconcat
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc "Add a git dependency. Experimental.",
|
||||
Opts.headerDoc $ Just $
|
||||
"Examples:"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> " niv add git git@github.com:stedolan/jq"
|
||||
Opts.<$$> " niv add git ssh://git@github.com/stedolan/jq --rev deadb33f"
|
||||
Opts.<$$> " niv add git https://github.com/stedolan/jq.git"
|
||||
Opts.<$$> " niv add git --repo /my/custom/repo --name custom --ref foobar"
|
||||
]
|
||||
|
||||
gitUpdate
|
||||
:: (T.Text -> T.Text -> IO T.Text) -- ^ latest rev
|
||||
-> (T.Text -> IO (T.Text, T.Text)) -- ^ latest rev and default ref
|
||||
-> Update () ()
|
||||
gitUpdate ::
|
||||
-- | latest rev
|
||||
(T.Text -> T.Text -> IO T.Text) ->
|
||||
-- | latest rev and default ref
|
||||
(T.Text -> IO (T.Text, T.Text)) ->
|
||||
Update () ()
|
||||
gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do
|
||||
useOrSet "type" -< ("git" :: Box T.Text)
|
||||
repository <- load "repo" -< ()
|
||||
discoverRev <+> discoverRefAndRev -< repository
|
||||
useOrSet "type" -< ("git" :: Box T.Text)
|
||||
repository <- load "repo" -< ()
|
||||
discoverRev <+> discoverRefAndRev -< repository
|
||||
where
|
||||
discoverRefAndRev = proc repository -> do
|
||||
refAndRev <- run defaultRefAndHEAD' -< repository
|
||||
@ -132,38 +141,46 @@ gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do
|
||||
gitUpdate' :: Update () ()
|
||||
gitUpdate' = gitUpdate latestRev defaultRefAndHEAD
|
||||
|
||||
latestRev
|
||||
:: T.Text -- ^ the repository
|
||||
-> T.Text -- ^ the ref/branch
|
||||
-> IO T.Text
|
||||
latestRev ::
|
||||
-- | the repository
|
||||
T.Text ->
|
||||
-- | the ref/branch
|
||||
T.Text ->
|
||||
IO T.Text
|
||||
latestRev repo ref = do
|
||||
let gitArgs = [ "ls-remote", repo, "refs/heads/" <> ref ]
|
||||
sout <- runGit gitArgs
|
||||
case sout of
|
||||
ls@(_:_:_) -> abortTooMuchOutput gitArgs ls
|
||||
(l1:[]) -> parseRev gitArgs l1
|
||||
[] -> abortNoOutput gitArgs
|
||||
let gitArgs = ["ls-remote", repo, "refs/heads/" <> ref]
|
||||
sout <- runGit gitArgs
|
||||
case sout of
|
||||
ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls
|
||||
(l1 : []) -> parseRev gitArgs l1
|
||||
[] -> abortNoOutput gitArgs
|
||||
where
|
||||
parseRev args l = maybe (abortNoRev args l) pure $ do
|
||||
checkRev $ T.takeWhile (/= '\t') l
|
||||
checkRev t = if isRev t then Just t else Nothing
|
||||
abortNoOutput args = abortGitFailure args
|
||||
"Git didn't produce any output."
|
||||
abortTooMuchOutput args ls = abortGitFailure args $ T.unlines $
|
||||
[ "Git produced too much output:" ] <> map (" " <>) ls
|
||||
abortNoOutput args =
|
||||
abortGitFailure
|
||||
args
|
||||
"Git didn't produce any output."
|
||||
abortTooMuchOutput args ls =
|
||||
abortGitFailure args $ T.unlines $
|
||||
["Git produced too much output:"] <> map (" " <>) ls
|
||||
|
||||
defaultRefAndHEAD
|
||||
:: T.Text -- ^ the repository
|
||||
-> IO (T.Text, T.Text)
|
||||
defaultRefAndHEAD ::
|
||||
-- | the repository
|
||||
T.Text ->
|
||||
IO (T.Text, T.Text)
|
||||
defaultRefAndHEAD repo = do
|
||||
sout <- runGit args
|
||||
case sout of
|
||||
(l1:l2:_) -> (,) <$> parseRef l1 <*> parseRev l2
|
||||
_ -> abortGitFailure args $ T.unlines $
|
||||
sout <- runGit args
|
||||
case sout of
|
||||
(l1 : l2 : _) -> (,) <$> parseRef l1 <*> parseRev l2
|
||||
_ ->
|
||||
abortGitFailure args $ T.unlines $
|
||||
[ "Could not read reference and revision from stdout:"
|
||||
] <> sout
|
||||
]
|
||||
<> sout
|
||||
where
|
||||
args = [ "ls-remote", "--symref", repo, "HEAD" ]
|
||||
args = ["ls-remote", "--symref", repo, "HEAD"]
|
||||
parseRef l = maybe (abortNoRef args l) pure $ do
|
||||
-- ref: refs/head/master\tHEAD -> master\tHEAD
|
||||
refAndSym <- T.stripPrefix "ref: refs/heads/" l
|
||||
@ -175,29 +192,36 @@ defaultRefAndHEAD repo = do
|
||||
|
||||
abortNoRev :: [T.Text] -> T.Text -> IO a
|
||||
abortNoRev args l = abortGitFailure args $ "Could not read revision from: " <> l
|
||||
|
||||
abortNoRef :: [T.Text] -> T.Text -> IO a
|
||||
abortNoRef args l = abortGitFailure args $ "Could not read reference from: " <> l
|
||||
|
||||
-- | Run the "git" executable
|
||||
runGit :: [T.Text] -> IO [T.Text]
|
||||
runGit args = do
|
||||
(exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) ""
|
||||
case (exitCode, lines sout) of
|
||||
(ExitSuccess, ls) -> pure $ T.pack <$> ls
|
||||
_ -> abortGitFailure args $ T.unlines
|
||||
[ T.unwords [ "stdout:" , T.pack sout ]
|
||||
, T.unwords [ "stderr:" , T.pack serr ]
|
||||
]
|
||||
(exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) ""
|
||||
case (exitCode, lines sout) of
|
||||
(ExitSuccess, ls) -> pure $ T.pack <$> ls
|
||||
_ ->
|
||||
abortGitFailure args $
|
||||
T.unlines
|
||||
[ T.unwords ["stdout:", T.pack sout],
|
||||
T.unwords ["stderr:", T.pack serr]
|
||||
]
|
||||
|
||||
isRev :: T.Text -> Bool
|
||||
isRev t =
|
||||
-- commit hashes are comprised of abcdef0123456789
|
||||
T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t &&
|
||||
-- commit _should_ be 40 chars long, but to be sure we pick 7
|
||||
T.length t >= 7
|
||||
T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t
|
||||
&&
|
||||
-- commit _should_ be 40 chars long, but to be sure we pick 7
|
||||
T.length t >= 7
|
||||
|
||||
abortGitFailure :: [T.Text] -> T.Text -> IO a
|
||||
abortGitFailure args msg = abort $ bug $ T.unlines
|
||||
[ "Could not read the output of 'git'."
|
||||
, T.unwords ("command:":"git":args)
|
||||
, msg ]
|
||||
abortGitFailure args msg =
|
||||
abort $ bug $
|
||||
T.unlines
|
||||
[ "Could not read the output of 'git'.",
|
||||
T.unwords ("command:" : "git" : args),
|
||||
msg
|
||||
]
|
||||
|
||||
@ -1,63 +1,77 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Niv.Git.Test (tests) where
|
||||
module Niv.Git.Test
|
||||
( tests,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Bifunctor
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Niv.Git.Cmd
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import Test.Tasty.HUnit ((@=?))
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Test.Tasty as Tasty
|
||||
import Test.Tasty.HUnit ((@=?))
|
||||
import qualified Test.Tasty.HUnit as Tasty
|
||||
|
||||
tests :: [Tasty.TestTree]
|
||||
tests = [ test_repositoryParse , test_gitUpdates ]
|
||||
tests = [test_repositoryParse, test_gitUpdates]
|
||||
|
||||
test_repositoryParse :: Tasty.TestTree
|
||||
test_repositoryParse = Tasty.testGroup "repository parse"
|
||||
[ Tasty.testCase "goo" $
|
||||
parseGitShortcut "goo" @=? Nothing
|
||||
, Tasty.testCase "git@github.com:nmattia/niv" $
|
||||
parseGitShortcut "git@github.com:nmattia/niv" @=? Just
|
||||
(PackageName "niv", HMS.singleton "repo" "git@github.com:nmattia/niv")
|
||||
, Tasty.testCase "ssh://git@github.com/stedolan/jq" $
|
||||
parseGitShortcut "ssh://git@github.com/stedolan/jq" @=? Just
|
||||
(PackageName "jq", HMS.singleton "repo" "ssh://git@github.com/stedolan/jq")
|
||||
, Tasty.testCase "https://github.com/stedolan/jq.git" $
|
||||
parseGitShortcut "https://github.com/stedolan/jq.git" @=? Just
|
||||
(PackageName "jq", HMS.singleton "repo" "https://github.com/stedolan/jq.git")
|
||||
, Tasty.testCase "https://github.com/stedolan/jq" $
|
||||
parseGitShortcut "https://github.com/stedolan/jq" @=? Nothing
|
||||
, Tasty.testCase "~/path/to/repo.git" $
|
||||
parseGitShortcut "~/path/to/repo.git" @=? Just
|
||||
(PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git")
|
||||
]
|
||||
test_repositoryParse =
|
||||
Tasty.testGroup
|
||||
"repository parse"
|
||||
[ Tasty.testCase "goo" $
|
||||
parseGitShortcut "goo" @=? Nothing,
|
||||
Tasty.testCase "git@github.com:nmattia/niv" $
|
||||
parseGitShortcut "git@github.com:nmattia/niv"
|
||||
@=? Just
|
||||
(PackageName "niv", HMS.singleton "repo" "git@github.com:nmattia/niv"),
|
||||
Tasty.testCase "ssh://git@github.com/stedolan/jq" $
|
||||
parseGitShortcut "ssh://git@github.com/stedolan/jq"
|
||||
@=? Just
|
||||
(PackageName "jq", HMS.singleton "repo" "ssh://git@github.com/stedolan/jq"),
|
||||
Tasty.testCase "https://github.com/stedolan/jq.git" $
|
||||
parseGitShortcut "https://github.com/stedolan/jq.git"
|
||||
@=? Just
|
||||
(PackageName "jq", HMS.singleton "repo" "https://github.com/stedolan/jq.git"),
|
||||
Tasty.testCase "https://github.com/stedolan/jq" $
|
||||
parseGitShortcut "https://github.com/stedolan/jq" @=? Nothing,
|
||||
Tasty.testCase "~/path/to/repo.git" $
|
||||
parseGitShortcut "~/path/to/repo.git"
|
||||
@=? Just
|
||||
(PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git")
|
||||
]
|
||||
|
||||
test_gitUpdates :: Tasty.TestTree
|
||||
test_gitUpdates = Tasty.testGroup "updates"
|
||||
[ Tasty.testCase "rev is updated" test_gitUpdateRev
|
||||
]
|
||||
test_gitUpdates =
|
||||
Tasty.testGroup
|
||||
"updates"
|
||||
[ Tasty.testCase "rev is updated" test_gitUpdateRev
|
||||
]
|
||||
|
||||
test_gitUpdateRev :: IO ()
|
||||
test_gitUpdateRev = do
|
||||
interState <- evalUpdate initialState $ proc () ->
|
||||
gitUpdate (error "should be def") defaultRefAndHEAD' -< ()
|
||||
let interState' = HMS.map (first (\_ -> Free)) interState
|
||||
actualState <- evalUpdate interState' $ proc () ->
|
||||
gitUpdate latestRev' (error "should update") -< ()
|
||||
unless ((snd <$> actualState) == expectedState) $
|
||||
error $ "State mismatch: " <> show actualState
|
||||
interState <- evalUpdate initialState $ proc () ->
|
||||
gitUpdate (error "should be def") defaultRefAndHEAD' -< ()
|
||||
let interState' = HMS.map (first (\_ -> Free)) interState
|
||||
actualState <- evalUpdate interState' $ proc () ->
|
||||
gitUpdate latestRev' (error "should update") -< ()
|
||||
unless ((snd <$> actualState) == expectedState)
|
||||
$ error
|
||||
$ "State mismatch: " <> show actualState
|
||||
where
|
||||
latestRev' _ _ = pure "some-other-rev"
|
||||
defaultRefAndHEAD' _ = pure ("some-ref", "some-rev")
|
||||
initialState = HMS.fromList
|
||||
[ ("repo", (Free, "git@github.com:nmattia/niv")) ]
|
||||
expectedState = HMS.fromList
|
||||
[ ("repo", "git@github.com:nmattia/niv")
|
||||
, ("ref", "some-ref")
|
||||
, ("rev", "some-other-rev")
|
||||
, ("type", "git")
|
||||
]
|
||||
initialState =
|
||||
HMS.fromList
|
||||
[("repo", (Free, "git@github.com:nmattia/niv"))]
|
||||
expectedState =
|
||||
HMS.fromList
|
||||
[ ("repo", "git@github.com:nmattia/niv"),
|
||||
("ref", "some-ref"),
|
||||
("rev", "some-other-rev"),
|
||||
("type", "git")
|
||||
]
|
||||
|
||||
@ -1,18 +1,18 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Niv.GitHub where
|
||||
|
||||
import Control.Arrow
|
||||
import Data.Bool
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Niv.GitHub.API
|
||||
import Niv.Update
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | The GitHub update function
|
||||
-- TODO: fetchers for:
|
||||
@ -20,39 +20,44 @@ import qualified Data.Text as T
|
||||
-- * 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
|
||||
(Bool -> T.Text -> IO T.Text) ->
|
||||
-- | latest revision
|
||||
(T.Text -> T.Text -> T.Text -> IO T.Text) ->
|
||||
-- | get repo
|
||||
(T.Text -> T.Text -> IO GithubRepo) ->
|
||||
Update () ()
|
||||
githubUpdate prefetch latestRev ghRepo = proc () -> do
|
||||
urlTemplate <- template <<<
|
||||
(useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -<
|
||||
urlTemplate <-
|
||||
template
|
||||
<<< (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -<
|
||||
()
|
||||
url <- update "url" -< urlTemplate
|
||||
let isTar = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> 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 -< ()
|
||||
url <- update "url" -< urlTemplate
|
||||
let isTar = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> 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
|
||||
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
|
||||
_ <-
|
||||
update "rev" <<< run' (\(a, b, c) -> latestRev a b c) -<
|
||||
(,,) <$> owner <*> repo <*> branch
|
||||
returnA -< pure githubURLTemplate
|
||||
|
||||
githubURLTemplate :: T.Text
|
||||
githubURLTemplate =
|
||||
(if githubSecure then "https://" else "http://") <>
|
||||
githubHost <> githubPath <> "<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
(if githubSecure then "https://" else "http://")
|
||||
<> githubHost
|
||||
<> githubPath
|
||||
<> "<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
|
||||
@ -1,64 +1,67 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Niv.GitHub.API where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import Data.Functor
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.Maybe
|
||||
import Data.String.QQ (s)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Data.Text.Extended
|
||||
import qualified Network.HTTP.Simple as HTTP
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Text.Read (readMaybe)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Network.HTTP.Simple as HTTP
|
||||
|
||||
-- Bunch of GitHub helpers
|
||||
|
||||
data GithubRepo = GithubRepo
|
||||
{ repoDescription :: Maybe T.Text
|
||||
, repoHomepage :: Maybe T.Text
|
||||
, repoDefaultBranch :: Maybe T.Text
|
||||
}
|
||||
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 = do
|
||||
request <- defaultRequest ["repos", owner, repo]
|
||||
-- we don't use httpJSONEither because it adds an "Accept:
|
||||
-- application/json" header that GitHub chokes on
|
||||
resp0 <- HTTP.httpBS request
|
||||
let resp = fmap Aeson.eitherDecodeStrict resp0
|
||||
case (HTTP.getResponseStatusCode resp, HTTP.getResponseBody resp) of
|
||||
(200, Right (Aeson.Object m)) -> do
|
||||
let lookupText k = case HMS.lookup k m of
|
||||
Just (Aeson.String t) -> Just t
|
||||
_ -> Nothing
|
||||
pure GithubRepo
|
||||
{ repoDescription = lookupText "description"
|
||||
, repoHomepage = lookupText "homepage"
|
||||
, repoDefaultBranch = lookupText "default_branch"
|
||||
request <- defaultRequest ["repos", owner, repo]
|
||||
-- we don't use httpJSONEither because it adds an "Accept:
|
||||
-- application/json" header that GitHub chokes on
|
||||
resp0 <- HTTP.httpBS request
|
||||
let resp = fmap Aeson.eitherDecodeStrict resp0
|
||||
case (HTTP.getResponseStatusCode resp, HTTP.getResponseBody resp) of
|
||||
(200, Right (Aeson.Object m)) -> do
|
||||
let lookupText k = case HMS.lookup k m of
|
||||
Just (Aeson.String t) -> Just t
|
||||
_ -> Nothing
|
||||
pure
|
||||
GithubRepo
|
||||
{ repoDescription = lookupText "description",
|
||||
repoHomepage = lookupText "homepage",
|
||||
repoDefaultBranch = lookupText "default_branch"
|
||||
}
|
||||
(200, Right v) -> do
|
||||
error $ "expected object, got " <> show v
|
||||
(200, Left e) -> do
|
||||
error $ "github didn't return JSON: " <> show e
|
||||
_ -> abortCouldNotFetchGitHubRepo (tshow (request,resp0)) (owner, repo)
|
||||
(200, Right v) -> do
|
||||
error $ "expected object, got " <> show v
|
||||
(200, Left e) -> do
|
||||
error $ "github didn't return JSON: " <> show e
|
||||
_ -> abortCouldNotFetchGitHubRepo (tshow (request, resp0)) (owner, repo)
|
||||
|
||||
-- | TODO: Error instead of T.Text?
|
||||
abortCouldNotFetchGitHubRepo :: T.Text -> (T.Text, T.Text) -> IO a
|
||||
abortCouldNotFetchGitHubRepo e (T.unpack -> owner, T.unpack -> repo) = do
|
||||
putStrLn $ unlines [ line1, line2, T.unpack line3 ]
|
||||
exitFailure
|
||||
putStrLn $ unlines [line1, line2, T.unpack line3]
|
||||
exitFailure
|
||||
where
|
||||
line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo
|
||||
line2 = [s|
|
||||
line2 =
|
||||
[s|
|
||||
I assumed that your package was a GitHub repository. An error occurred while
|
||||
gathering information from the repository. Check whether your package was added
|
||||
correctly:
|
||||
@ -72,52 +75,55 @@ If not, try re-adding it:
|
||||
|
||||
Make sure the repository exists.
|
||||
|]
|
||||
line3 = T.unwords [ "(Error was:", e, ")" ]
|
||||
line3 = T.unwords ["(Error was:", e, ")"]
|
||||
|
||||
defaultRequest :: [T.Text] -> IO HTTP.Request
|
||||
defaultRequest (map T.encodeUtf8 -> parts) = do
|
||||
let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts)
|
||||
mtoken <- lookupEnv "GITHUB_TOKEN"
|
||||
pure $
|
||||
(flip (maybe id) mtoken $ \token ->
|
||||
HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)
|
||||
) $
|
||||
HTTP.setRequestPath path $
|
||||
HTTP.addRequestHeader "user-agent" "niv" $
|
||||
HTTP.addRequestHeader "accept" "application/vnd.github.v3+json" $
|
||||
HTTP.setRequestSecure githubSecure $
|
||||
HTTP.setRequestHost (T.encodeUtf8 githubApiHost) $
|
||||
HTTP.setRequestPort githubApiPort $
|
||||
HTTP.defaultRequest
|
||||
let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts)
|
||||
mtoken <- lookupEnv "GITHUB_TOKEN"
|
||||
pure
|
||||
$ ( flip (maybe id) mtoken $ \token ->
|
||||
HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)
|
||||
)
|
||||
$ HTTP.setRequestPath path
|
||||
$ HTTP.addRequestHeader "user-agent" "niv"
|
||||
$ HTTP.addRequestHeader "accept" "application/vnd.github.v3+json"
|
||||
$ HTTP.setRequestSecure githubSecure
|
||||
$ HTTP.setRequestHost (T.encodeUtf8 githubApiHost)
|
||||
$ HTTP.setRequestPort githubApiPort
|
||||
$ HTTP.defaultRequest
|
||||
|
||||
-- | 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
|
||||
T.Text ->
|
||||
-- | repo
|
||||
T.Text ->
|
||||
-- | branch
|
||||
T.Text ->
|
||||
IO T.Text
|
||||
githubLatestRev owner repo branch = do
|
||||
request <- defaultRequest [ "repos", owner, repo, "commits", branch ] <&>
|
||||
HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha"
|
||||
resp <- HTTP.httpBS request
|
||||
case HTTP.getResponseStatusCode resp of
|
||||
200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp
|
||||
_ -> abortCouldNotGetRev owner repo branch resp
|
||||
request <-
|
||||
defaultRequest ["repos", owner, repo, "commits", branch]
|
||||
<&> HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha"
|
||||
resp <- HTTP.httpBS request
|
||||
case HTTP.getResponseStatusCode resp of
|
||||
200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp
|
||||
_ -> abortCouldNotGetRev owner repo branch resp
|
||||
|
||||
abortCouldNotGetRev :: T.Text -> T.Text -> T.Text -> HTTP.Response BS8.ByteString -> IO a
|
||||
abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [ line1, line2, line3 ]
|
||||
abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [line1, line2, line3]
|
||||
where
|
||||
line1 = T.unwords
|
||||
[ "Cannot get latest revision for branch"
|
||||
, "'" <> branch <> "'"
|
||||
, "(" <> owner <> "/" <> repo <> ")"
|
||||
]
|
||||
line1 =
|
||||
T.unwords
|
||||
[ "Cannot get latest revision for branch",
|
||||
"'" <> branch <> "'",
|
||||
"(" <> owner <> "/" <> repo <> ")"
|
||||
]
|
||||
line2 = "The request failed: " <> tshow resp
|
||||
line3 = [s|
|
||||
line3 =
|
||||
[s|
|
||||
NOTE: You may want to retry with an authentication token:
|
||||
|
||||
GITHUB_TOKEN=... niv <cmd>
|
||||
@ -130,31 +136,31 @@ For more information on rate-limiting, see
|
||||
|
||||
githubHost :: T.Text
|
||||
githubHost = unsafePerformIO $ do
|
||||
lookupEnv "GITHUB_HOST" >>= \case
|
||||
Just (T.pack -> x) -> pure x
|
||||
Nothing -> pure "github.com"
|
||||
lookupEnv "GITHUB_HOST" >>= \case
|
||||
Just (T.pack -> x) -> pure x
|
||||
Nothing -> pure "github.com"
|
||||
|
||||
githubApiPort :: Int
|
||||
githubApiPort = unsafePerformIO $ do
|
||||
lookupEnv "GITHUB_API_PORT" >>= \case
|
||||
Just (readMaybe -> Just x) -> pure x
|
||||
_ -> pure $ if githubSecure then 443 else 80
|
||||
lookupEnv "GITHUB_API_PORT" >>= \case
|
||||
Just (readMaybe -> Just x) -> pure x
|
||||
_ -> pure $ if githubSecure then 443 else 80
|
||||
|
||||
githubApiHost :: T.Text
|
||||
githubApiHost = unsafePerformIO $ do
|
||||
lookupEnv "GITHUB_API_HOST" >>= \case
|
||||
Just (T.pack -> x) -> pure x
|
||||
Nothing -> pure "api.github.com"
|
||||
lookupEnv "GITHUB_API_HOST" >>= \case
|
||||
Just (T.pack -> x) -> pure x
|
||||
Nothing -> pure "api.github.com"
|
||||
|
||||
githubSecure :: Bool
|
||||
githubSecure = unsafePerformIO $ do
|
||||
lookupEnv "GITHUB_INSECURE" >>= \case
|
||||
Just "" -> pure True
|
||||
Just _ -> pure False
|
||||
Nothing -> pure True
|
||||
lookupEnv "GITHUB_INSECURE" >>= \case
|
||||
Just "" -> pure True
|
||||
Just _ -> pure False
|
||||
Nothing -> pure True
|
||||
|
||||
githubPath :: T.Text
|
||||
githubPath = unsafePerformIO $ do
|
||||
lookupEnv "GITHUB_PATH" >>= \case
|
||||
Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/"
|
||||
Nothing -> pure "/"
|
||||
lookupEnv "GITHUB_PATH" >>= \case
|
||||
Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/"
|
||||
Nothing -> pure "/"
|
||||
|
||||
@ -1,133 +1,153 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Niv.GitHub.Cmd (githubCmd) where
|
||||
module Niv.GitHub.Cmd
|
||||
( githubCmd,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Bifunctor
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import Data.Char (isAlphaNum)
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.Maybe
|
||||
import Data.String.QQ (s)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Extended
|
||||
import Niv.Cmd
|
||||
import Niv.GitHub
|
||||
import Niv.GitHub.API
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import System.Exit (ExitCode(ExitSuccess))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
import qualified Options.Applicative as Opts
|
||||
import qualified Options.Applicative.Help.Pretty as Opts
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
|
||||
githubCmd :: Cmd
|
||||
githubCmd = Cmd
|
||||
{ description = describeGitHub
|
||||
, parseCmdShortcut = parseAddShortcutGitHub
|
||||
, parsePackageSpec = parseGitHubPackageSpec
|
||||
, updateCmd = githubUpdate'
|
||||
, name = "github"
|
||||
-- TODO: here filter by type == tarball or file or builtin-
|
||||
}
|
||||
githubCmd =
|
||||
Cmd
|
||||
{ description = describeGitHub,
|
||||
parseCmdShortcut = parseAddShortcutGitHub,
|
||||
parsePackageSpec = parseGitHubPackageSpec,
|
||||
updateCmd = githubUpdate',
|
||||
name = "github"
|
||||
-- TODO: here filter by type == tarball or file or builtin-
|
||||
}
|
||||
|
||||
parseGitHubPackageSpec :: Opts.Parser PackageSpec
|
||||
parseGitHubPackageSpec =
|
||||
(PackageSpec . HMS.fromList) <$>
|
||||
many parseAttribute
|
||||
(PackageSpec . HMS.fromList)
|
||||
<$> many parseAttribute
|
||||
where
|
||||
parseAttribute :: Opts.Parser (T.Text, Aeson.Value)
|
||||
parseAttribute =
|
||||
Opts.option (Opts.maybeReader parseKeyValJSON)
|
||||
( Opts.long "attribute" <>
|
||||
Opts.short 'a' <>
|
||||
Opts.metavar "KEY=VAL" <>
|
||||
Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."
|
||||
) <|>
|
||||
Opts.option (Opts.maybeReader (parseKeyVal Aeson.toJSON))
|
||||
( Opts.long "string-attribute" <>
|
||||
Opts.short 's' <>
|
||||
Opts.metavar "KEY=VAL" <>
|
||||
Opts.help "Set the package spec attribute <KEY> to <VAL>."
|
||||
) <|>
|
||||
shortcutAttributes <|>
|
||||
((("url_template",) . Aeson.String) <$> Opts.strOption
|
||||
( Opts.long "template" <>
|
||||
Opts.short 't' <>
|
||||
Opts.metavar "URL" <>
|
||||
Opts.help "Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."
|
||||
)) <|>
|
||||
((("type",) . Aeson.String) <$> Opts.strOption
|
||||
( Opts.long "type" <>
|
||||
Opts.short 'T' <>
|
||||
Opts.metavar "TYPE" <>
|
||||
Opts.help "The type of the URL target. The value can be either 'file' or 'tarball'. If not set, the value is inferred from the suffix of the URL."
|
||||
))
|
||||
|
||||
Opts.option
|
||||
(Opts.maybeReader parseKeyValJSON)
|
||||
( Opts.long "attribute"
|
||||
<> Opts.short 'a'
|
||||
<> Opts.metavar "KEY=VAL"
|
||||
<> Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."
|
||||
)
|
||||
<|> Opts.option
|
||||
(Opts.maybeReader (parseKeyVal Aeson.toJSON))
|
||||
( Opts.long "string-attribute"
|
||||
<> Opts.short 's'
|
||||
<> Opts.metavar "KEY=VAL"
|
||||
<> Opts.help "Set the package spec attribute <KEY> to <VAL>."
|
||||
)
|
||||
<|> shortcutAttributes
|
||||
<|> ( (("url_template",) . Aeson.String)
|
||||
<$> Opts.strOption
|
||||
( Opts.long "template"
|
||||
<> Opts.short 't'
|
||||
<> Opts.metavar "URL"
|
||||
<> Opts.help "Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."
|
||||
)
|
||||
)
|
||||
<|> ( (("type",) . Aeson.String)
|
||||
<$> Opts.strOption
|
||||
( Opts.long "type"
|
||||
<> Opts.short 'T'
|
||||
<> Opts.metavar "TYPE"
|
||||
<> Opts.help "The type of the URL target. The value can be either 'file' or 'tarball'. If not set, the value is inferred from the suffix of the URL."
|
||||
)
|
||||
)
|
||||
parseKeyValJSON = parseKeyVal $ \x ->
|
||||
fromMaybe (Aeson.toJSON x) (Aeson.decodeStrict (B8.pack x))
|
||||
|
||||
-- Parse "key=val" into ("key", val)
|
||||
parseKeyVal
|
||||
:: (String -> Aeson.Value) -- ^ how to convert to JSON
|
||||
-> String -> Maybe (T.Text, Aeson.Value)
|
||||
parseKeyVal ::
|
||||
-- | how to convert to JSON
|
||||
(String -> Aeson.Value) ->
|
||||
String ->
|
||||
Maybe (T.Text, Aeson.Value)
|
||||
parseKeyVal toJSON str = case span (/= '=') str of
|
||||
(key, '=':val) -> Just (T.pack key, toJSON val)
|
||||
(key, '=' : val) -> Just (T.pack key, toJSON val)
|
||||
_ -> Nothing
|
||||
|
||||
-- Shortcuts for common attributes
|
||||
shortcutAttributes :: Opts.Parser (T.Text, Aeson.Value)
|
||||
shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>
|
||||
[ "branch", "owner", "repo", "version" ]
|
||||
|
||||
shortcutAttributes =
|
||||
foldr (<|>) empty $
|
||||
mkShortcutAttribute
|
||||
<$> ["branch", "owner", "repo", "version"]
|
||||
-- TODO: infer those shortcuts from 'Update' keys
|
||||
mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, Aeson.Value)
|
||||
mkShortcutAttribute = \case
|
||||
attr@(T.uncons -> Just (c,_)) -> fmap (second Aeson.String) $ (attr,) <$> Opts.strOption
|
||||
( Opts.long (T.unpack attr) <>
|
||||
Opts.short c <>
|
||||
Opts.metavar (T.unpack $ T.toUpper attr) <>
|
||||
Opts.help
|
||||
( T.unpack $
|
||||
"Equivalent to --attribute " <>
|
||||
attr <> "=<" <> (T.toUpper attr) <> ">"
|
||||
)
|
||||
)
|
||||
attr@(T.uncons -> Just (c, _)) ->
|
||||
fmap (second Aeson.String) $
|
||||
(attr,)
|
||||
<$> Opts.strOption
|
||||
( Opts.long (T.unpack attr)
|
||||
<> Opts.short c
|
||||
<> Opts.metavar (T.unpack $ T.toUpper attr)
|
||||
<> Opts.help
|
||||
( T.unpack $
|
||||
"Equivalent to --attribute "
|
||||
<> attr
|
||||
<> "=<"
|
||||
<> (T.toUpper attr)
|
||||
<> ">"
|
||||
)
|
||||
)
|
||||
_ -> empty
|
||||
|
||||
describeGitHub :: Opts.InfoMod a
|
||||
describeGitHub = mconcat
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Add a GitHub dependency"
|
||||
, Opts.headerDoc $ Just $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
" niv add stedolan/jq" Opts.<$$>
|
||||
" niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable" Opts.<$$>
|
||||
" niv add my-package -v alpha-0.1 -t http://example.com/archive/<version>.zip"
|
||||
]
|
||||
describeGitHub =
|
||||
mconcat
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc "Add a GitHub dependency",
|
||||
Opts.headerDoc $ Just $
|
||||
"Examples:"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> " niv add stedolan/jq"
|
||||
Opts.<$$> " niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable"
|
||||
Opts.<$$> " niv add my-package -v alpha-0.1 -t http://example.com/archive/<version>.zip"
|
||||
]
|
||||
|
||||
-- parse a github shortcut of the form "owner/repo"
|
||||
parseAddShortcutGitHub :: T.Text -> Maybe (PackageName, Aeson.Object)
|
||||
parseAddShortcutGitHub str =
|
||||
-- parses a string "owner/repo" into package name (repo) and spec (owner +
|
||||
-- repo)
|
||||
case T.span (/= '/') str of
|
||||
(owner@(T.null -> False)
|
||||
, T.uncons -> Just ('/', repo@(T.null -> False))) -> Just
|
||||
( PackageName repo
|
||||
, HMS.fromList [ "owner" .= owner, "repo" .= repo ])
|
||||
-- XXX: this should be "Nothing" but for the time being we keep
|
||||
-- backwards compatibility with "niv add foo" adding "foo" as a
|
||||
-- package name.
|
||||
_ -> Just (PackageName str, HMS.empty)
|
||||
-- parses a string "owner/repo" into package name (repo) and spec (owner +
|
||||
-- repo)
|
||||
case T.span (/= '/') str of
|
||||
( owner@(T.null -> False),
|
||||
T.uncons -> Just ('/', repo@(T.null -> False))
|
||||
) ->
|
||||
Just
|
||||
( PackageName repo,
|
||||
HMS.fromList ["owner" .= owner, "repo" .= repo]
|
||||
)
|
||||
-- XXX: this should be "Nothing" but for the time being we keep
|
||||
-- backwards compatibility with "niv add foo" adding "foo" as a
|
||||
-- package name.
|
||||
_ -> Just (PackageName str, HMS.empty)
|
||||
|
||||
-- | The IO (real) github update
|
||||
githubUpdate' :: Update () ()
|
||||
@ -135,12 +155,12 @@ githubUpdate' = githubUpdate nixPrefetchURL githubLatestRev githubRepo
|
||||
|
||||
nixPrefetchURL :: Bool -> T.Text -> IO T.Text
|
||||
nixPrefetchURL unpack turl@(T.unpack -> url) = do
|
||||
(exitCode, sout, serr) <- runNixPrefetch
|
||||
case (exitCode, lines sout) of
|
||||
(ExitSuccess, l:_) -> pure $ T.pack l
|
||||
_ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr)
|
||||
(exitCode, sout, serr) <- runNixPrefetch
|
||||
case (exitCode, lines sout) of
|
||||
(ExitSuccess, l : _) -> pure $ T.pack l
|
||||
_ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr)
|
||||
where
|
||||
args = (if unpack then ["--unpack"] else []) <> [ url, "--name", sanitizeName basename]
|
||||
args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename]
|
||||
runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args ""
|
||||
sanitizeName = T.unpack . T.filter isOk
|
||||
basename = last $ T.splitOn "/" turl
|
||||
@ -151,11 +171,14 @@ nixPrefetchURL unpack turl@(T.unpack -> url) = do
|
||||
isOk = \c -> isAlphaNum c || T.any (c ==) "+-._?="
|
||||
|
||||
abortNixPrefetchExpectedOutput :: [T.Text] -> T.Text -> T.Text -> IO a
|
||||
abortNixPrefetchExpectedOutput args sout serr = abort $ [s|
|
||||
abortNixPrefetchExpectedOutput args sout serr =
|
||||
abort $
|
||||
[s|
|
||||
Could not read the output of 'nix-prefetch-url'. This is a bug. Please create a
|
||||
ticket:
|
||||
|
||||
https://github.com/nmattia/niv/issues/new
|
||||
|
||||
Thanks! I'll buy you a beer.
|
||||
|] <> T.unlines ["command: ", "nix-prefetch-url" <> T.unwords args, "stdout: ", sout, "stderr: ", serr]
|
||||
|]
|
||||
<> T.unlines ["command: ", "nix-prefetch-url" <> T.unwords args, "stdout: ", sout, "stderr: ", serr]
|
||||
|
||||
@ -5,156 +5,172 @@
|
||||
module Niv.GitHub.Test where
|
||||
|
||||
import Control.Monad
|
||||
import Data.IORef
|
||||
import Data.Bifunctor
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.IORef
|
||||
import Niv.GitHub
|
||||
import Niv.GitHub.API
|
||||
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
|
||||
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")
|
||||
]
|
||||
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
|
||||
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")
|
||||
]
|
||||
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
|
||||
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")
|
||||
]
|
||||
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
|
||||
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")
|
||||
]
|
||||
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")
|
||||
]
|
||||
|
||||
test_githubUpdatesOnce :: IO ()
|
||||
test_githubUpdatesOnce = do
|
||||
ioref <- newIORef False
|
||||
tmpState <- evalUpdate initialState $ proc () ->
|
||||
githubUpdate (prefetch ioref) latestRev ghRepo -< ()
|
||||
|
||||
unless ((snd <$> tmpState) == expectedState) $
|
||||
error $ "State mismatch: " <> show tmpState
|
||||
|
||||
-- Set everything free
|
||||
let tmpState' = HMS.map (first (\_ -> Free)) tmpState
|
||||
actualState <- evalUpdate tmpState' $ proc () ->
|
||||
githubUpdate (prefetch ioref) latestRev ghRepo -< ()
|
||||
|
||||
unless ((snd <$> actualState) == expectedState) $
|
||||
error $ "State mismatch: " <> show actualState
|
||||
ioref <- newIORef False
|
||||
tmpState <- evalUpdate initialState $ proc () ->
|
||||
githubUpdate (prefetch ioref) latestRev ghRepo -< ()
|
||||
unless ((snd <$> tmpState) == expectedState)
|
||||
$ error
|
||||
$ "State mismatch: " <> show tmpState
|
||||
-- Set everything free
|
||||
let tmpState' = HMS.map (first (\_ -> Free)) tmpState
|
||||
actualState <- evalUpdate tmpState' $ proc () ->
|
||||
githubUpdate (prefetch ioref) latestRev ghRepo -< ()
|
||||
unless ((snd <$> actualState) == expectedState)
|
||||
$ error
|
||||
$ "State mismatch: " <> show actualState
|
||||
where
|
||||
prefetch ioref _ _ = do
|
||||
readIORef ioref >>= \case
|
||||
@ -163,32 +179,36 @@ test_githubUpdatesOnce = do
|
||||
writeIORef ioref True
|
||||
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")
|
||||
]
|
||||
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")
|
||||
]
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
@ -8,32 +8,34 @@
|
||||
|
||||
module Niv.Local.Cmd where
|
||||
|
||||
import Niv.Cmd
|
||||
import Control.Arrow
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
import Niv.Cmd
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import qualified Options.Applicative as Opts
|
||||
import qualified Options.Applicative.Help.Pretty as Opts
|
||||
|
||||
localCmd :: Cmd
|
||||
localCmd = Cmd
|
||||
{ description = describeLocal
|
||||
, parseCmdShortcut = parseLocalShortcut
|
||||
, parsePackageSpec = parseLocalPackageSpec
|
||||
, updateCmd = proc () -> do
|
||||
useOrSet "type" -< ("local" :: Box T.Text)
|
||||
returnA -< ()
|
||||
, name = "local"
|
||||
}
|
||||
localCmd =
|
||||
Cmd
|
||||
{ description = describeLocal,
|
||||
parseCmdShortcut = parseLocalShortcut,
|
||||
parsePackageSpec = parseLocalPackageSpec,
|
||||
updateCmd = proc () -> do
|
||||
useOrSet "type" -< ("local" :: Box T.Text)
|
||||
returnA -< (),
|
||||
name = "local"
|
||||
}
|
||||
|
||||
parseLocalShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
|
||||
parseLocalShortcut txt =
|
||||
if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt ) then do
|
||||
if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt)
|
||||
then do
|
||||
let n = last $ T.splitOn "/" txt
|
||||
Just (PackageName n, HMS.fromList [ ("path", Aeson.String txt) ])
|
||||
Just (PackageName n, HMS.fromList [("path", Aeson.String txt)])
|
||||
else Nothing
|
||||
|
||||
parseLocalPackageSpec :: Opts.Parser PackageSpec
|
||||
@ -41,19 +43,20 @@ parseLocalPackageSpec = PackageSpec . HMS.fromList <$> parseParams
|
||||
where
|
||||
parseParams :: Opts.Parser [(T.Text, Aeson.Value)]
|
||||
parseParams = maybe [] pure <$> Opts.optional parsePath
|
||||
|
||||
parsePath =
|
||||
("path", ) . Aeson.String <$> Opts.strOption
|
||||
( Opts.long "path" <>
|
||||
Opts.metavar "PATH"
|
||||
)
|
||||
("path",) . Aeson.String
|
||||
<$> Opts.strOption
|
||||
( Opts.long "path"
|
||||
<> Opts.metavar "PATH"
|
||||
)
|
||||
|
||||
describeLocal :: Opts.InfoMod a
|
||||
describeLocal = mconcat
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Add a local dependency. Experimental."
|
||||
, Opts.headerDoc $ Just $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
" niv add local ./foo/bar"
|
||||
]
|
||||
describeLocal =
|
||||
mconcat
|
||||
[ Opts.fullDesc,
|
||||
Opts.progDesc "Add a local dependency. Experimental.",
|
||||
Opts.headerDoc $ Just $
|
||||
"Examples:"
|
||||
Opts.<$$> ""
|
||||
Opts.<$$> " niv add local ./foo/bar"
|
||||
]
|
||||
|
||||
@ -1,47 +1,55 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Niv.Logger
|
||||
( job
|
||||
, bug
|
||||
, tsay
|
||||
, say
|
||||
, green, tgreen
|
||||
, red, tred
|
||||
, blue, tblue
|
||||
, yellow, tyellow
|
||||
, bold, tbold
|
||||
, faint, tfaint
|
||||
) where
|
||||
( job,
|
||||
bug,
|
||||
tsay,
|
||||
say,
|
||||
green,
|
||||
tgreen,
|
||||
red,
|
||||
tred,
|
||||
blue,
|
||||
tblue,
|
||||
yellow,
|
||||
tyellow,
|
||||
bold,
|
||||
tbold,
|
||||
faint,
|
||||
tfaint,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Profunctor
|
||||
import qualified Data.Text as T
|
||||
import qualified System.Console.ANSI as ANSI
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Data.Text as T
|
||||
import UnliftIO
|
||||
import qualified System.Console.ANSI as ANSI
|
||||
|
||||
type S = String -> String
|
||||
|
||||
type T = T.Text -> T.Text
|
||||
|
||||
-- XXX: this assumes as single thread
|
||||
job :: (MonadUnliftIO io, MonadIO io) => String -> io () -> io ()
|
||||
job str act = do
|
||||
say (bold str)
|
||||
indent
|
||||
tryAny act <* deindent >>= \case
|
||||
Right () -> say $ green "Done" <> ": " <> str
|
||||
Left e -> do
|
||||
-- don't wrap if the error ain't too long
|
||||
let showErr = do
|
||||
let se = show e
|
||||
(if length se > 40 then ":\n" else ": ") <> se
|
||||
say $ red "ERROR" <> showErr
|
||||
liftIO exitFailure
|
||||
say (bold str)
|
||||
indent
|
||||
tryAny act <* deindent >>= \case
|
||||
Right () -> say $ green "Done" <> ": " <> str
|
||||
Left e -> do
|
||||
-- don't wrap if the error ain't too long
|
||||
let showErr = do
|
||||
let se = show e
|
||||
(if length se > 40 then ":\n" else ": ") <> se
|
||||
say $ red "ERROR" <> showErr
|
||||
liftIO exitFailure
|
||||
where
|
||||
indent = void $ atomicModifyIORef jobStack (\x -> (x + 1, undefined))
|
||||
deindent = void $ atomicModifyIORef jobStack (\x -> (x - 1, undefined))
|
||||
@ -51,6 +59,7 @@ jobStackSize = readIORef jobStack
|
||||
|
||||
jobStack :: IORef Int
|
||||
jobStack = unsafePerformIO $ newIORef 0
|
||||
|
||||
{-# NOINLINE jobStackSize #-}
|
||||
|
||||
tsay :: MonadIO io => T.Text -> io ()
|
||||
@ -58,61 +67,67 @@ tsay = say . T.unpack
|
||||
|
||||
say :: MonadIO io => String -> io ()
|
||||
say msg = do
|
||||
stackSize <- jobStackSize
|
||||
let indent = replicate (stackSize * 2) ' '
|
||||
-- we use `intercalate "\n"` because `unlines` prints an extra newline at
|
||||
-- the end
|
||||
liftIO $ putStrLn $ intercalate "\n" $ (indent <>) <$> lines msg
|
||||
stackSize <- jobStackSize
|
||||
let indent = replicate (stackSize * 2) ' '
|
||||
-- we use `intercalate "\n"` because `unlines` prints an extra newline at
|
||||
-- the end
|
||||
liftIO $ putStrLn $ intercalate "\n" $ (indent <>) <$> lines msg
|
||||
|
||||
green :: S
|
||||
green str =
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] <>
|
||||
str <> ANSI.setSGRCode [ANSI.Reset]
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
|
||||
<> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green]
|
||||
<> str
|
||||
<> ANSI.setSGRCode [ANSI.Reset]
|
||||
|
||||
tgreen :: T
|
||||
tgreen = t green
|
||||
|
||||
yellow :: S
|
||||
yellow str =
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow] <>
|
||||
str <> ANSI.setSGRCode [ANSI.Reset]
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
|
||||
<> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow]
|
||||
<> str
|
||||
<> ANSI.setSGRCode [ANSI.Reset]
|
||||
|
||||
tyellow :: T
|
||||
tyellow = t yellow
|
||||
|
||||
blue :: S
|
||||
blue str =
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue] <>
|
||||
str <> ANSI.setSGRCode [ANSI.Reset]
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
|
||||
<> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue]
|
||||
<> str
|
||||
<> ANSI.setSGRCode [ANSI.Reset]
|
||||
|
||||
tblue :: T
|
||||
tblue = t blue
|
||||
|
||||
red :: S
|
||||
red str =
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] <>
|
||||
str <> ANSI.setSGRCode [ANSI.Reset]
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]
|
||||
<> str
|
||||
<> ANSI.setSGRCode [ANSI.Reset]
|
||||
|
||||
tred :: T
|
||||
tred = t red
|
||||
|
||||
bold :: S
|
||||
bold str =
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <>
|
||||
str <> ANSI.setSGRCode [ANSI.Reset]
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
|
||||
<> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]
|
||||
<> str
|
||||
<> ANSI.setSGRCode [ANSI.Reset]
|
||||
|
||||
tbold :: T
|
||||
tbold = t bold
|
||||
|
||||
faint :: String -> String
|
||||
faint str =
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity] <>
|
||||
ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <>
|
||||
str <> ANSI.setSGRCode [ANSI.Reset]
|
||||
ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity]
|
||||
<> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]
|
||||
<> str
|
||||
<> ANSI.setSGRCode [ANSI.Reset]
|
||||
|
||||
tfaint :: T
|
||||
tfaint = t faint
|
||||
@ -121,9 +136,10 @@ t :: (String -> String) -> T.Text -> T.Text
|
||||
t = dimap T.unpack T.pack
|
||||
|
||||
bug :: T.Text -> T.Text
|
||||
bug txt = T.unlines
|
||||
[ txt
|
||||
, "This is a bug. Please create a ticket:"
|
||||
, " https://github.com/nmattia/niv/issues/new"
|
||||
, "Thanks! I'll buy you a beer."
|
||||
]
|
||||
bug txt =
|
||||
T.unlines
|
||||
[ txt,
|
||||
"This is a bug. Please create a ticket:",
|
||||
" https://github.com/nmattia/niv/issues/new",
|
||||
"Thanks! I'll buy you a beer."
|
||||
]
|
||||
|
||||
@ -1,31 +1,31 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Niv.Sources where
|
||||
|
||||
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.List
|
||||
import Data.String.QQ (s)
|
||||
import Data.Text.Extended
|
||||
import Niv.Logger
|
||||
import Niv.Update
|
||||
import System.FilePath ((</>))
|
||||
import UnliftIO
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Extended as Aeson
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL8
|
||||
import qualified Data.Digest.Pure.MD5 as MD5
|
||||
import Data.FileEmbed (embedFile)
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.List
|
||||
import Data.String.QQ (s)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Extended
|
||||
import Niv.Logger
|
||||
import Niv.Update
|
||||
import qualified System.Directory as Dir
|
||||
import System.FilePath ((</>))
|
||||
import UnliftIO
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- sources.json related
|
||||
@ -33,57 +33,65 @@ import qualified System.Directory as Dir
|
||||
|
||||
-- | Where to find the sources.json
|
||||
data FindSourcesJson
|
||||
= Auto -- ^ use the default (nix/sources.json)
|
||||
| AtPath FilePath -- ^ use the specified file path
|
||||
= -- | use the default (nix/sources.json)
|
||||
Auto
|
||||
| -- | use the specified file path
|
||||
AtPath FilePath
|
||||
|
||||
data SourcesError
|
||||
= SourcesDoesntExist
|
||||
| SourceIsntJSON
|
||||
| SpecIsntAMap
|
||||
|
||||
newtype Sources = Sources
|
||||
{ unSources :: HMS.HashMap PackageName PackageSpec }
|
||||
newtype Sources
|
||||
= Sources
|
||||
{unSources :: HMS.HashMap PackageName PackageSpec}
|
||||
deriving newtype (FromJSON, ToJSON)
|
||||
|
||||
getSourcesEither :: FindSourcesJson -> IO (Either SourcesError Sources)
|
||||
getSourcesEither fsj = do
|
||||
Dir.doesFileExist (pathNixSourcesJson fsj) >>= \case
|
||||
False -> pure $ Left SourcesDoesntExist
|
||||
True ->
|
||||
Aeson.decodeFileStrict (pathNixSourcesJson fsj) >>= \case
|
||||
Just value -> case valueToSources value of
|
||||
Nothing -> pure $ Left SpecIsntAMap
|
||||
Just srcs -> pure $ Right srcs
|
||||
Nothing -> pure $ Left SourceIsntJSON
|
||||
Dir.doesFileExist (pathNixSourcesJson fsj) >>= \case
|
||||
False -> pure $ Left SourcesDoesntExist
|
||||
True ->
|
||||
Aeson.decodeFileStrict (pathNixSourcesJson fsj) >>= \case
|
||||
Just value -> case valueToSources value of
|
||||
Nothing -> pure $ Left SpecIsntAMap
|
||||
Just srcs -> pure $ Right srcs
|
||||
Nothing -> pure $ Left SourceIsntJSON
|
||||
where
|
||||
valueToSources :: Aeson.Value -> Maybe Sources
|
||||
valueToSources = \case
|
||||
Aeson.Object obj -> fmap (Sources . mapKeys PackageName) $ traverse
|
||||
(\case
|
||||
Aeson.Object obj' -> Just (PackageSpec obj')
|
||||
_ -> Nothing
|
||||
) obj
|
||||
_ -> Nothing
|
||||
Aeson.Object obj ->
|
||||
fmap (Sources . mapKeys PackageName) $
|
||||
traverse
|
||||
( \case
|
||||
Aeson.Object obj' -> Just (PackageSpec obj')
|
||||
_ -> Nothing
|
||||
)
|
||||
obj
|
||||
_ -> Nothing
|
||||
mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v
|
||||
mapKeys f = HMS.fromList . map (first f) . HMS.toList
|
||||
|
||||
getSources :: FindSourcesJson -> IO Sources
|
||||
getSources fsj = do
|
||||
warnIfOutdated
|
||||
getSourcesEither fsj >>= either
|
||||
(\case
|
||||
SourcesDoesntExist -> (abortSourcesDoesntExist fsj)
|
||||
SourceIsntJSON -> (abortSourcesIsntJSON fsj)
|
||||
SpecIsntAMap -> (abortSpecIsntAMap fsj)
|
||||
) pure
|
||||
warnIfOutdated
|
||||
getSourcesEither fsj
|
||||
>>= either
|
||||
( \case
|
||||
SourcesDoesntExist -> (abortSourcesDoesntExist fsj)
|
||||
SourceIsntJSON -> (abortSourcesIsntJSON fsj)
|
||||
SpecIsntAMap -> (abortSpecIsntAMap fsj)
|
||||
)
|
||||
pure
|
||||
|
||||
setSources :: FindSourcesJson -> Sources -> IO ()
|
||||
setSources fsj sources = Aeson.encodeFilePretty (pathNixSourcesJson fsj) sources
|
||||
|
||||
newtype PackageName = PackageName { unPackageName :: T.Text }
|
||||
newtype PackageName = PackageName {unPackageName :: T.Text}
|
||||
deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show)
|
||||
|
||||
newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object }
|
||||
newtype PackageSpec = PackageSpec {unPackageSpec :: Aeson.Object}
|
||||
deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid)
|
||||
|
||||
-- | Simply discards the 'Freedom'
|
||||
@ -93,32 +101,34 @@ attrsToSpec = PackageSpec . fmap snd
|
||||
-- | @nix/sources.json@ or pointed at by 'FindSourcesJson'
|
||||
pathNixSourcesJson :: FindSourcesJson -> FilePath
|
||||
pathNixSourcesJson = \case
|
||||
Auto -> "nix" </> "sources.json"
|
||||
AtPath f -> f
|
||||
Auto -> "nix" </> "sources.json"
|
||||
AtPath f -> f
|
||||
|
||||
--
|
||||
-- ABORT messages
|
||||
--
|
||||
|
||||
abortSourcesDoesntExist :: FindSourcesJson -> IO a
|
||||
abortSourcesDoesntExist fsj = abort $ T.unlines [ line1, line2 ]
|
||||
abortSourcesDoesntExist fsj = abort $ T.unlines [line1, line2]
|
||||
where
|
||||
line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj)
|
||||
line2 = [s|
|
||||
line2 =
|
||||
[s|
|
||||
The sources file does not exist! You may need to run 'niv init'.
|
||||
|]
|
||||
|
||||
abortSourcesIsntJSON :: FindSourcesJson -> IO a
|
||||
abortSourcesIsntJSON fsj = abort $ T.unlines [ line1, line2 ]
|
||||
abortSourcesIsntJSON fsj = abort $ T.unlines [line1, line2]
|
||||
where
|
||||
line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj)
|
||||
line2 = "The sources file should be JSON."
|
||||
|
||||
abortSpecIsntAMap :: FindSourcesJson -> IO a
|
||||
abortSpecIsntAMap fsj = abort $ T.unlines [ line1, line2 ]
|
||||
abortSpecIsntAMap fsj = abort $ T.unlines [line1, line2]
|
||||
where
|
||||
line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj)
|
||||
line2 = [s|
|
||||
line2 =
|
||||
[s|
|
||||
The package specifications in the sources file should be JSON maps from
|
||||
attribute name to attribute value, e.g.:
|
||||
{ "nixpkgs": { "foo": "bar" } }
|
||||
@ -128,7 +138,6 @@ attribute name to attribute value, e.g.:
|
||||
-- sources.nix related
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
|
||||
-- | All the released versions of nix/sources.nix
|
||||
data SourcesNixVersion
|
||||
= V1
|
||||
@ -148,32 +157,32 @@ data SourcesNixVersion
|
||||
| V15
|
||||
| V16
|
||||
| V17
|
||||
-- prettify derivation name
|
||||
-- add 'local' type of sources
|
||||
| V18
|
||||
| -- prettify derivation name
|
||||
-- add 'local' type of sources
|
||||
V18
|
||||
deriving stock (Bounded, Enum, Eq)
|
||||
|
||||
-- | A user friendly version
|
||||
sourcesVersionToText :: SourcesNixVersion -> T.Text
|
||||
sourcesVersionToText = \case
|
||||
V1 -> "1"
|
||||
V2 -> "2"
|
||||
V3 -> "3"
|
||||
V4 -> "4"
|
||||
V5 -> "5"
|
||||
V6 -> "6"
|
||||
V7 -> "7"
|
||||
V8 -> "8"
|
||||
V9 -> "9"
|
||||
V10 -> "10"
|
||||
V11 -> "11"
|
||||
V12 -> "12"
|
||||
V13 -> "13"
|
||||
V14 -> "14"
|
||||
V15 -> "15"
|
||||
V16 -> "16"
|
||||
V17 -> "17"
|
||||
V18 -> "18"
|
||||
V1 -> "1"
|
||||
V2 -> "2"
|
||||
V3 -> "3"
|
||||
V4 -> "4"
|
||||
V5 -> "5"
|
||||
V6 -> "6"
|
||||
V7 -> "7"
|
||||
V8 -> "8"
|
||||
V9 -> "9"
|
||||
V10 -> "10"
|
||||
V11 -> "11"
|
||||
V12 -> "12"
|
||||
V13 -> "13"
|
||||
V14 -> "14"
|
||||
V15 -> "15"
|
||||
V16 -> "16"
|
||||
V17 -> "17"
|
||||
V18 -> "18"
|
||||
|
||||
latestVersionMD5 :: T.Text
|
||||
latestVersionMD5 = sourcesVersionToMD5 maxBound
|
||||
@ -181,29 +190,29 @@ latestVersionMD5 = sourcesVersionToMD5 maxBound
|
||||
-- | Find a version based on the md5 of the nix/sources.nix
|
||||
md5ToSourcesVersion :: T.Text -> Maybe SourcesNixVersion
|
||||
md5ToSourcesVersion md5 =
|
||||
find (\snv -> sourcesVersionToMD5 snv == md5) [minBound .. maxBound]
|
||||
find (\snv -> sourcesVersionToMD5 snv == md5) [minBound .. maxBound]
|
||||
|
||||
-- | The MD5 sum of a particular version
|
||||
sourcesVersionToMD5 :: SourcesNixVersion -> T.Text
|
||||
sourcesVersionToMD5 = \case
|
||||
V1 -> "a7d3532c70fea66ffa25d6bc7ee49ad5"
|
||||
V2 -> "24cc0719fa744420a04361e23a3598d0"
|
||||
V3 -> "e01ed051e2c416e0fc7355fc72aeee3d"
|
||||
V4 -> "f754fe0e661b61abdcd32cb4062f5014"
|
||||
V5 -> "c34523590ff7dec7bf0689f145df29d1"
|
||||
V6 -> "8143f1db1e209562faf80a998be4929a"
|
||||
V7 -> "00a02cae76d30bbef96f001cabeed96f"
|
||||
V8 -> "e8b860753dd7fa1fd7b805dd836eb607"
|
||||
V9 -> "87149616c1b3b1e5aa73178f91c20b53"
|
||||
V10 -> "d8625c0a03dd935e1c79f46407faa8d3"
|
||||
V11 -> "8a95b7d93b16f7c7515d98f49b0ec741"
|
||||
V12 -> "2f9629ad9a8f181ed71d2a59b454970c"
|
||||
V13 -> "5e23c56b92eaade4e664cb16dcac1e0a"
|
||||
V14 -> "b470e235e7bcbf106d243fea90b6cfc9"
|
||||
V15 -> "dc11af910773ec9b4e505e0f49ebcfd2"
|
||||
V16 -> "2d93c52cab8e960e767a79af05ca572a"
|
||||
V17 -> "149b8907f7b08dc1c28164dfa55c7fad"
|
||||
V18 -> "bc5e6aefcaa6f9e0b2155ca4f44e5a33"
|
||||
V1 -> "a7d3532c70fea66ffa25d6bc7ee49ad5"
|
||||
V2 -> "24cc0719fa744420a04361e23a3598d0"
|
||||
V3 -> "e01ed051e2c416e0fc7355fc72aeee3d"
|
||||
V4 -> "f754fe0e661b61abdcd32cb4062f5014"
|
||||
V5 -> "c34523590ff7dec7bf0689f145df29d1"
|
||||
V6 -> "8143f1db1e209562faf80a998be4929a"
|
||||
V7 -> "00a02cae76d30bbef96f001cabeed96f"
|
||||
V8 -> "e8b860753dd7fa1fd7b805dd836eb607"
|
||||
V9 -> "87149616c1b3b1e5aa73178f91c20b53"
|
||||
V10 -> "d8625c0a03dd935e1c79f46407faa8d3"
|
||||
V11 -> "8a95b7d93b16f7c7515d98f49b0ec741"
|
||||
V12 -> "2f9629ad9a8f181ed71d2a59b454970c"
|
||||
V13 -> "5e23c56b92eaade4e664cb16dcac1e0a"
|
||||
V14 -> "b470e235e7bcbf106d243fea90b6cfc9"
|
||||
V15 -> "dc11af910773ec9b4e505e0f49ebcfd2"
|
||||
V16 -> "2d93c52cab8e960e767a79af05ca572a"
|
||||
V17 -> "149b8907f7b08dc1c28164dfa55c7fad"
|
||||
V18 -> "bc5e6aefcaa6f9e0b2155ca4f44e5a33"
|
||||
|
||||
-- | The MD5 sum of ./nix/sources.nix
|
||||
sourcesNixMD5 :: IO T.Text
|
||||
@ -215,30 +224,36 @@ pathNixSourcesNix = "nix" </> "sources.nix"
|
||||
|
||||
warnIfOutdated :: IO ()
|
||||
warnIfOutdated = do
|
||||
tryAny (BL8.readFile pathNixSourcesNix) >>= \case
|
||||
Left e -> tsay $ T.unlines -- warn with tsay
|
||||
[ T.unwords [ tyellow "WARNING:", "Could not read" , T.pack pathNixSourcesNix ]
|
||||
, T.unwords [ " ", "(", tshow e, ")" ]
|
||||
]
|
||||
Right content -> do
|
||||
case md5ToSourcesVersion (T.pack $ show $ MD5.md5 content) of
|
||||
-- This is a custom or newer version, we don't do anything
|
||||
Nothing -> pure ()
|
||||
Just v
|
||||
-- The file is the latest
|
||||
| v == maxBound -> pure ()
|
||||
-- The file is older than than latest
|
||||
| otherwise -> do
|
||||
tsay $ T.unlines
|
||||
[ T.unwords
|
||||
[ tbold $ tblue "INFO:"
|
||||
, "new sources.nix available:"
|
||||
, sourcesVersionToText v, "->", sourcesVersionToText maxBound
|
||||
]
|
||||
, " Please run 'niv init' or add the following line in the " <>
|
||||
T.pack pathNixSourcesNix <> " file:"
|
||||
, " # niv: no_update"
|
||||
]
|
||||
tryAny (BL8.readFile pathNixSourcesNix) >>= \case
|
||||
Left e ->
|
||||
tsay $
|
||||
T.unlines -- warn with tsay
|
||||
[ T.unwords [tyellow "WARNING:", "Could not read", T.pack pathNixSourcesNix],
|
||||
T.unwords [" ", "(", tshow e, ")"]
|
||||
]
|
||||
Right content -> do
|
||||
case md5ToSourcesVersion (T.pack $ show $ MD5.md5 content) of
|
||||
-- This is a custom or newer version, we don't do anything
|
||||
Nothing -> pure ()
|
||||
Just v
|
||||
-- The file is the latest
|
||||
| v == maxBound -> pure ()
|
||||
-- The file is older than than latest
|
||||
| otherwise -> do
|
||||
tsay $
|
||||
T.unlines
|
||||
[ T.unwords
|
||||
[ tbold $ tblue "INFO:",
|
||||
"new sources.nix available:",
|
||||
sourcesVersionToText v,
|
||||
"->",
|
||||
sourcesVersionToText maxBound
|
||||
],
|
||||
" Please run 'niv init' or add the following line in the "
|
||||
<> T.pack pathNixSourcesNix
|
||||
<> " file:",
|
||||
" # niv: no_update"
|
||||
]
|
||||
|
||||
-- | Glue code between nix and sources.json
|
||||
initNixSourcesNixContent :: B.ByteString
|
||||
|
||||
@ -1,13 +1,13 @@
|
||||
module Niv.Sources.Test where
|
||||
|
||||
import Niv.Sources
|
||||
import Test.Tasty.HUnit ((@=?))
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Digest.Pure.MD5 as MD5
|
||||
import qualified Data.Text as T
|
||||
import Niv.Sources
|
||||
import Test.Tasty.HUnit ((@=?))
|
||||
|
||||
-- | Ensure that the sources.nix we ship is tracked as the latest version
|
||||
test_shippedSourcesNixIsLatest :: IO ()
|
||||
test_shippedSourcesNixIsLatest =
|
||||
latestVersionMD5 @=?
|
||||
(T.pack . show . MD5.md5 . BL.fromStrict $ initNixSourcesNixContent)
|
||||
latestVersionMD5
|
||||
@=? (T.pack . show . MD5.md5 . BL.fromStrict $ initNixSourcesNixContent)
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
module Niv.Test (tests, test) where
|
||||
|
||||
import Niv.Sources.Test
|
||||
import Niv.GitHub.Test
|
||||
import Niv.Update.Test
|
||||
import qualified Niv.Git.Test as Git
|
||||
import Niv.GitHub.Test
|
||||
import Niv.Sources.Test
|
||||
import Niv.Update.Test
|
||||
import qualified Test.Tasty as Tasty
|
||||
import qualified Test.Tasty.HUnit as Tasty
|
||||
|
||||
@ -11,26 +11,31 @@ test :: IO ()
|
||||
test = Tasty.defaultMain tests
|
||||
|
||||
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 "updates once" test_githubUpdatesOnce
|
||||
, Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev
|
||||
, Tasty.testCase "falls back to URL" test_githubURLFallback
|
||||
]
|
||||
, Tasty.testGroup "sources.nix"
|
||||
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 "updates once" test_githubUpdatesOnce,
|
||||
Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev,
|
||||
Tasty.testCase "falls back to URL" test_githubURLFallback
|
||||
],
|
||||
Tasty.testGroup
|
||||
"sources.nix"
|
||||
[ Tasty.testCase "has latest version" test_shippedSourcesNixIsLatest
|
||||
]
|
||||
, Tasty.testGroup "git" Git.tests
|
||||
],
|
||||
Tasty.testGroup "git" Git.tests
|
||||
]
|
||||
|
||||
@ -12,14 +12,14 @@ module Niv.Update where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Data.Aeson (FromJSON, ToJSON, Value)
|
||||
import Data.String
|
||||
import Niv.Logger
|
||||
import UnliftIO
|
||||
import qualified Control.Category as Cat
|
||||
import Data.Aeson (FromJSON, ToJSON, Value)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
import Niv.Logger
|
||||
import UnliftIO
|
||||
|
||||
type Attrs = HMS.HashMap T.Text (Freedom, Value)
|
||||
|
||||
@ -34,27 +34,27 @@ data Update b c where
|
||||
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)
|
||||
Run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||
Template :: Update (Box T.Text) (Box T.Text)
|
||||
|
||||
instance ArrowZero Update where
|
||||
zeroArrow = Zero
|
||||
zeroArrow = Zero
|
||||
|
||||
instance ArrowPlus Update where
|
||||
(<+>) = Plus
|
||||
(<+>) = Plus
|
||||
|
||||
instance Arrow Update where
|
||||
arr = Arr
|
||||
first = First
|
||||
arr = Arr
|
||||
first = First
|
||||
|
||||
instance Cat.Category Update where
|
||||
id = Id
|
||||
f . g = Compose (Compose' f g)
|
||||
id = Id
|
||||
f . g = Compose (Compose' f g)
|
||||
|
||||
instance Show (Update b c) where
|
||||
show = \case
|
||||
Id -> "Id"
|
||||
Compose (Compose' f g)-> "(" <> show f <> " . " <> show g <> ")"
|
||||
Compose (Compose' f g) -> "(" <> show f <> " . " <> show g <> ")"
|
||||
Arr _f -> "Arr"
|
||||
First a -> "First " <> show a
|
||||
Zero -> "Zero"
|
||||
@ -83,10 +83,11 @@ runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed
|
||||
FailNoSuchKey k -> "Key could not be found: " <> k
|
||||
FailZero -> bug "A dead end was reached during evaluation."
|
||||
FailCheck -> "A check failed during update"
|
||||
FailTemplate tpl keys -> T.unlines
|
||||
[ "Could not render template " <> tpl
|
||||
, "with keys: " <> T.intercalate ", " keys
|
||||
]
|
||||
FailTemplate tpl keys ->
|
||||
T.unlines
|
||||
[ "Could not render template " <> tpl,
|
||||
"with keys: " <> T.intercalate ", " keys
|
||||
]
|
||||
|
||||
execUpdate :: Attrs -> Update () a -> IO a
|
||||
execUpdate attrs a = snd <$> runUpdate attrs a
|
||||
@ -104,41 +105,43 @@ data UpdateFailed
|
||||
| FailZero
|
||||
| FailCheck
|
||||
| FailTemplate T.Text [T.Text]
|
||||
deriving Show
|
||||
deriving (Show)
|
||||
|
||||
data UpdateRes a b
|
||||
= UpdateReady (UpdateReady b)
|
||||
| UpdateNeedMore (a -> IO (UpdateReady b))
|
||||
deriving Functor
|
||||
deriving (Functor)
|
||||
|
||||
data UpdateReady b
|
||||
= UpdateSuccess BoxedAttrs b
|
||||
| UpdateFailed UpdateFailed
|
||||
deriving Functor
|
||||
deriving (Functor)
|
||||
|
||||
runBox :: Box a -> IO a
|
||||
runBox = boxOp
|
||||
|
||||
data Box a = Box
|
||||
{ boxNew :: Bool
|
||||
-- ^ Whether the value is new or was retrieved (or derived) from old
|
||||
-- attributes
|
||||
, boxOp :: IO a
|
||||
}
|
||||
deriving Functor
|
||||
data Box a
|
||||
= Box
|
||||
{ -- | Whether the value is new or was retrieved (or derived) from old
|
||||
-- attributes
|
||||
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
|
||||
}
|
||||
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 }
|
||||
fromString str = Box {boxNew = False, boxOp = pure $ T.pack str}
|
||||
|
||||
type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value)
|
||||
|
||||
@ -146,12 +149,16 @@ 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
|
||||
))
|
||||
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
|
||||
@ -163,84 +170,94 @@ data Freedom
|
||||
-- In most cases I just picked the first implementation that compiled
|
||||
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)
|
||||
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 do
|
||||
v' <- boxOp v
|
||||
gtt' <- boxOp gtt
|
||||
-- Here we compare the old and new values, flagging the new one as
|
||||
-- "boxNew" iff they differ.
|
||||
-- TODO: generalize this to all boxes
|
||||
let gtt'' = if v' /= gtt' then gtt { boxNew = True, boxOp = pure gtt' }
|
||||
else gtt { boxNew = False, boxOp = pure gtt' }
|
||||
let gtt'' =
|
||||
if v' /= gtt'
|
||||
then gtt {boxNew = True, boxOp = pure gtt'}
|
||||
else gtt {boxNew = False, boxOp = pure gtt'}
|
||||
pure $ UpdateSuccess (HMS.insert k (Locked, gtt'') attrs) gtt''
|
||||
else do
|
||||
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
|
||||
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) -> 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 $ "When rendering template " <> v') . 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
|
||||
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 $ "When rendering template " <> v') . 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 => T.Text -> Box Value -> Box a
|
||||
decodeBox msg v = v { boxOp = boxOp v >>= decodeValue msg }
|
||||
decodeBox msg v = v {boxOp = boxOp v >>= decodeValue msg}
|
||||
|
||||
decodeValue :: FromJSON a => T.Text -> Value -> IO a
|
||||
decodeValue msg v = case Aeson.fromJSON v of
|
||||
@ -254,16 +271,16 @@ decodeValue msg v = case Aeson.fromJSON v of
|
||||
-- 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
|
||||
(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
|
||||
@ -277,15 +294,15 @@ load k = Load k >>> arr (decodeBox $ "When loading key " <> k)
|
||||
-- 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 $ "When trying to use or set key " <> k)
|
||||
arr (fmap Aeson.toJSON)
|
||||
>>> UseOrSet k
|
||||
>>> arr (decodeBox $ "When trying to use or set key " <> k)
|
||||
|
||||
update :: JSON a => T.Text -> Update (Box a) (Box a)
|
||||
update k =
|
||||
arr (fmap Aeson.toJSON) >>>
|
||||
Update k >>>
|
||||
arr (decodeBox $ "When updating key " <> k)
|
||||
arr (fmap Aeson.toJSON)
|
||||
>>> Update k
|
||||
>>> arr (decodeBox $ "When updating key " <> k)
|
||||
|
||||
run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||
run = Run
|
||||
@ -295,4 +312,4 @@ 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 })
|
||||
dirty = arr (\v -> v {boxNew = True})
|
||||
|
||||
@ -1,46 +1,48 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
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
|
||||
import Niv.Update
|
||||
|
||||
simplyRuns :: IO ()
|
||||
simplyRuns =
|
||||
void $ runUpdate attrs $ proc () -> do
|
||||
returnA -< ()
|
||||
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")
|
||||
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")
|
||||
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")
|
||||
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 () ()
|
||||
@ -58,55 +60,59 @@ survivesChecks = do
|
||||
|
||||
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))
|
||||
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'
|
||||
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"
|
||||
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"
|
||||
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"))]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user