1
1
mirror of https://github.com/nmattia/niv.git synced 2024-11-07 22:36:53 +03:00

Run Ormolu

This commit is contained in:
Nicolas Mattia 2020-07-23 16:24:16 +02:00
parent 1edb6856ad
commit e0bfb5d007
18 changed files with 1482 additions and 1289 deletions

View File

@ -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
}

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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
}

View File

@ -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
]

View File

@ -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")
]

View File

@ -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"

View File

@ -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 "/"

View File

@ -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]

View File

@ -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")
]

View File

@ -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"
]

View File

@ -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."
]

View File

@ -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

View File

@ -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)

View File

@ -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
]

View File

@ -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})

View File

@ -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"))]