update-nix-fetchgit (empty) → 0.1.0.0
raw patch · 10 files changed
+555/−0 lines, 10 filesdep +aesondep +ansi-wl-pprintdep +asyncsetup-changed
Dependencies added: aeson, ansi-wl-pprint, async, base, bytestring, data-fix, errors, hnix, process, text, time, transformers, trifecta, uniplate, update-nix-fetchgit, utf8-string
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- app/Main.hs +39/−0
- src/Update/Nix/FetchGit.hs +109/−0
- src/Update/Nix/FetchGit/Prefetch.hs +37/−0
- src/Update/Nix/FetchGit/Types.hs +49/−0
- src/Update/Nix/FetchGit/Utils.hs +133/−0
- src/Update/Nix/FetchGit/Warning.hs +15/−0
- src/Update/Span.hs +87/−0
- update-nix-fetchgit.cabal +53/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Joe Hermaszewski (c) 2016+Copyright David Grayson (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Joe Hermaszewski nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE LambdaCase #-}++module Main where++import Data.Text.IO (readFile, writeFile)+import Prelude hiding (readFile, writeFile)+import System.Environment (getArgs)+import System.Exit+import System.IO (hPutStrLn, stderr)+import Update.Nix.FetchGit+import Update.Nix.FetchGit.Utils+import Update.Nix.FetchGit.Warning+import Update.Span++main :: IO ()+main =+ -- Super simple command line parsing at the moment, just look for one+ -- filename.+ getArgs >>= \case+ [filename] -> do+ t <- readFile filename+ -- Get the updates from this file.+ updatesFromFile filename >>= \case+ -- If we have any errors, print them and finish.+ Left ws -> printErrorAndExit ws+ Right us ->+ -- Update the text of the file in memory.+ case updateSpans us t of+ -- If updates are needed, write to the file.+ t' | t' /= t -> writeFile filename t'+ _ -> return ()+ _ -> do+ putStrLn "Usage: update-nix-fetchgit filename"+ exitWith (ExitFailure 1)++printErrorAndExit :: Warning -> IO ()+printErrorAndExit e = do+ hPutStrLn stderr (formatWarning e)+ exitWith (ExitFailure 1)
+ src/Update/Nix/FetchGit.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Update.Nix.FetchGit+ ( updatesFromFile+ ) where++import Control.Concurrent.Async (mapConcurrently)+import Control.Error+import Data.Foldable (toList)+import Data.Generics.Uniplate.Data (para)+import Data.Text (pack)+import Nix.Expr+import Update.Nix.FetchGit.Prefetch+import Update.Nix.FetchGit.Types+import Update.Nix.FetchGit.Utils+import Update.Nix.FetchGit.Warning+import Update.Span++--------------------------------------------------------------------------------+-- Tying it all together+--------------------------------------------------------------------------------++-- | Given the path to a Nix file, returns the SpanUpdates+-- all the parts of the file we want to update.+updatesFromFile :: FilePath -> IO (Either Warning [SpanUpdate])+updatesFromFile f = runExceptT $ do+ expr <- ExceptT $ ourParseNixFile f+ treeWithArgs <- hoistEither $ exprToFetchTree expr+ treeWithLatest <- ExceptT $+ sequenceA <$> mapConcurrently getFetchGitLatestInfo treeWithArgs+ pure (fetchTreeToSpanUpdates treeWithLatest)++--------------------------------------------------------------------------------+-- Extracting information about fetches from the AST+--------------------------------------------------------------------------------++-- Get a FetchTree from a nix expression.+exprToFetchTree :: NExprLoc -> Either Warning (FetchTree FetchGitArgs)+exprToFetchTree = para $ \e subs -> case e of+ -- If it is a call (application) of fetchgit, record the+ -- arguments since we will need to update them.+ AnnE _ (NApp function (AnnE _ (NSet bindings)))+ | extractFuncName function == Just "fetchgit"+ || extractFuncName function == Just "fetchgitPrivate"+ -> FetchNode <$> extractFetchGitArgs bindings++ -- Similarly, record calls to fetchFromGitHub.+ AnnE _ (NApp function (AnnE _ (NSet bindings)))+ | extractFuncName function == Just "fetchFromGitHub"+ -> FetchNode <$> extractFetchFromGitHubArgs bindings++ -- If it is an attribute set, find any attributes in it that we+ -- might want to update.+ AnnE _ (NSet bindings)+ -> Node <$> findAttr "version" bindings <*> sequenceA subs++ -- If this is something uninteresting, just wrap the sub-trees.+ _ -> Node Nothing <$> sequenceA subs++-- | Extract a 'FetchGitArgs' from the attrset being passed to fetchgit.+extractFetchGitArgs :: [Binding NExprLoc] -> Either Warning FetchGitArgs+extractFetchGitArgs bindings =+ FetchGitArgs <$> (URL <$> (exprText =<< extractAttr "url" bindings))+ <*> extractAttr "rev" bindings+ <*> extractAttr "sha256" bindings++-- | Extract a 'FetchGitArgs' from the attrset being passed to fetchFromGitHub.+extractFetchFromGitHubArgs :: [Binding NExprLoc] -> Either Warning FetchGitArgs+extractFetchFromGitHubArgs bindings =+ FetchGitArgs <$> (GitHub <$> (exprText =<< extractAttr "owner" bindings)+ <*> (exprText =<< extractAttr "repo" bindings))+ <*> extractAttr "rev" bindings+ <*> extractAttr "sha256" bindings++--------------------------------------------------------------------------------+-- Getting updated information from the internet.+--------------------------------------------------------------------------------++getFetchGitLatestInfo :: FetchGitArgs -> IO (Either Warning FetchGitLatestInfo)+getFetchGitLatestInfo args = runExceptT $ do+ o <- ExceptT (nixPrefetchGit (extractUrlString $ repoLocation args))+ d <- hoistEither (parseISO8601DateToDay (date o))+ pure $ FetchGitLatestInfo args (rev o) (sha256 o) d++--------------------------------------------------------------------------------+-- Deciding which parts of the Nix file should be updated and how.+--------------------------------------------------------------------------------++fetchTreeToSpanUpdates :: FetchTree FetchGitLatestInfo -> [SpanUpdate]+fetchTreeToSpanUpdates node@(Node _ cs) =+ concatMap fetchTreeToSpanUpdates cs +++ toList (maybeUpdateVersion node)+fetchTreeToSpanUpdates (FetchNode f) = [revUpdate, sha256Update]+ where revUpdate = SpanUpdate (exprSpan (revExpr args))+ (quoteString (latestRev f))+ sha256Update = SpanUpdate (exprSpan (sha256Expr args))+ (quoteString (latestSha256 f))+ args = originalInfo f++-- Given a node of the fetch tree which might contain a version+-- string, decides whether and how that version string should be+-- updated. We basically just take the maximum latest commit date of+-- all the fetches in the children.+maybeUpdateVersion :: FetchTree FetchGitLatestInfo -> Maybe SpanUpdate+maybeUpdateVersion node@(Node (Just versionExpr) _) = do+ maxDay <- (maximumMay . fmap latestDate . toList) node+ pure $ SpanUpdate (exprSpan versionExpr) ((quoteString . pack . show) maxDay)+maybeUpdateVersion _ = Nothing
+ src/Update/Nix/FetchGit/Prefetch.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Update.Nix.FetchGit.Prefetch+ ( NixPrefetchGitOutput(..)+ , nixPrefetchGit+ ) where++import Control.Error+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (FromJSON, decode)+import Data.ByteString.Lazy.UTF8 (fromString)+import Data.Text+import GHC.Generics+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Update.Nix.FetchGit.Warning+++-- | The type of nix-prefetch-git's output+data NixPrefetchGitOutput = NixPrefetchGitOutput{ url :: Text+ , rev :: Text+ , sha256 :: Text+ , date :: Text+ }+ deriving (Show, Generic, FromJSON)++-- | Run nix-prefetch-git+nixPrefetchGit :: Text -- ^ The URL to prefetch+ -> IO (Either Warning NixPrefetchGitOutput)+nixPrefetchGit prefetchURL = runExceptT $ do+ (exitCode, nsStdout, nsStderr) <- liftIO $+ readProcessWithExitCode "nix-prefetch-git" [unpack prefetchURL] ""+ hoistEither $ case exitCode of+ ExitFailure e -> Left (NixPrefetchGitFailed e (pack nsStderr))+ ExitSuccess -> pure ()+ decode (fromString nsStdout) ?? InvalidPrefetchGitOutput (pack nsStdout)
+ src/Update/Nix/FetchGit/Types.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Update.Nix.FetchGit.Types where++import Data.Data (Data)+import Data.Text (Text)+import qualified Data.Time (Day)+import Nix.Expr (NExprLoc)++-- | The day portion of a date, with no timezone information.+type Day = Data.Time.Day++-- | A tree with a structure similar to the AST of the Nix file we are+-- parsing, but which only contains the information we care about.+-- The fetchInfo type parameter allows this tree to be used at+-- different stages in the program where we know different amounts of+-- information about a fetch expression.+data FetchTree fetchInfo = Node { nodeVersionExpr :: Maybe NExprLoc+ , nodeChildren :: [FetchTree fetchInfo]+ }+ | FetchNode fetchInfo+ deriving (Show, Data, Functor, Foldable, Traversable)++-- | Represents the arugments to a call to fetchgit or fetchFromGitHub+-- as parsed from a .nix file.+data FetchGitArgs = FetchGitArgs { repoLocation :: RepoLocation+ , revExpr :: NExprLoc+ , sha256Expr :: NExprLoc+ }+ deriving (Show, Data)++-- | Updated information about a fetchgit call that was retrieved from+-- the internet.+data FetchGitLatestInfo = FetchGitLatestInfo { originalInfo :: FetchGitArgs+ , latestRev :: Text+ , latestSha256 :: Text+ , latestDate :: Day+ }+ deriving (Show, Data)++-- | A repo is either specified by URL or by Github owner/repo.+data RepoLocation = URL Text+ | GitHub { owner :: Text+ , repo :: Text+ }+ deriving (Show, Data)
+ src/Update/Nix/FetchGit/Utils.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Update.Nix.FetchGit.Utils+ ( RepoLocation(..)+ , ourParseNixFile+ , extractUrlString+ , quoteString+ , extractFuncName+ , extractAttr+ , findAttr+ , exprText+ , exprSpan+ , parseISO8601DateToDay+ , formatWarning+ ) where++import Control.Error (lastMay)+import Data.Generics.Uniplate.Data (transform)+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import Data.Text (Text, unpack, splitOn)+import Data.Time (parseTimeM, defaultTimeLocale)+import Nix.Parser (parseNixFileLoc, Result(..))+import Text.Trifecta.Result (_errDoc)+import Nix.Expr+import Update.Nix.FetchGit.Types+import Update.Nix.FetchGit.Warning+import Update.Span++ourParseNixFile :: FilePath -> IO (Either Warning NExprLoc)+ourParseNixFile f =+ parseNixFileLoc f >>= \case+ Failure parseError -> pure $ Left (CouldNotParseInput (_errDoc parseError))+ Success expr -> pure $ pure $ fixNixSets expr++-- Convert all NRecSet values (recursive sets) to NSet values because+-- we do not care about the distinction between NRecSet and NSet and+-- we want our program to treat both types equally.+fixNixSets :: NExprLoc -> NExprLoc+fixNixSets = transform fix+ where fix (AnnE s (NRecSet bindings)) = AnnE s (NSet bindings)+ fix n = n++-- | Get the url from either a nix expression for the url or a repo and owner+-- expression.+extractUrlString :: RepoLocation -> Text+extractUrlString = \case+ URL u -> u+ GitHub o r -> "https://github.com/" <> o <> "/" <> r <> ".git"++-- Add double quotes around a string so it can be inserted into a Nix+-- file as a string literal.+quoteString :: Text -> Text+quoteString t = "\"" <> t <> "\""++-- | Get the string value of a particular expression, returns a 'Warning' if+-- the expression is not a string value.+--+-- TODO: Use 'evalExpr' here+exprText :: NExprLoc -> Either Warning Text+exprText = \case+ (AnnE _ (NStr (DoubleQuoted [Plain t]))) -> pure t+ e -> Left (NotAString e)++-- | Get the 'SourceSpan' covering a particular expression.+exprSpan :: NExprLoc -> SourceSpan+exprSpan expr = SourceSpan (deltaToSourcePos begin) (deltaToSourcePos end)+ where (AnnE (SrcSpan begin end) _) = expr++-- | Go from a 'Delta' to a 'SourcePos'.+deltaToSourcePos :: Delta -> SourcePos+deltaToSourcePos delta = SourcePos line column+ where (Directed _ line column _ _) = delta++-- | Given an expression that is supposed to represent a function,+-- extracts the name of the function. If we cannot figure out the+-- function name, returns Nothing.+extractFuncName :: NExprLoc -> Maybe Text+extractFuncName (AnnE _ (NSym name)) = Just name+extractFuncName (AnnE _ (NSelect _ (lastMay -> Just (StaticKey name)) _)) = Just name+extractFuncName _ = Nothing++-- | Extract a named attribute from an attrset.+extractAttr :: Text -> [Binding a] -> Either Warning a+extractAttr name bs = case catMaybes (matchAttr name <$> bs) of+ [x] -> pure x+ [] -> Left (MissingAttr name)+ _ -> Left (DuplicateAttrs name)++-- | Find a named attribute in an attrset. This is appropriate for+-- the case when a missing attribute is not an error.+findAttr :: Text -> [Binding a] -> Either Warning (Maybe a)+findAttr name bs = case catMaybes (matchAttr name <$> bs) of+ [x] -> pure (Just x)+ [] -> pure Nothing+ _ -> Left (DuplicateAttrs name)++-- | Returns 'Just value' if this attribute's key matches the text, otherwise+-- Nothing.+matchAttr :: Text -> Binding a -> Maybe a+matchAttr t = \case+ NamedVar [StaticKey t'] x | t == t' -> Just x+ NamedVar _ _ -> Nothing+ Inherit _ _ -> Nothing++-- Takes an ISO 8601 date and returns just the day portion.+parseISO8601DateToDay :: Text -> Either Warning Day+parseISO8601DateToDay t =+ let justDate = (unpack . Prelude.head . splitOn "T") t in+ case parseTimeM False defaultTimeLocale "%Y-%m-%d" justDate of+ Nothing -> Left $ InvalidDateString t+ Just day -> pure day++formatWarning :: Warning -> String+formatWarning (CouldNotParseInput doc) = show doc+formatWarning (MissingAttr attrName) =+ "Error: The \"" <> unpack attrName <> "\" attribute is missing."+formatWarning (DuplicateAttrs attrName) =+ "Error: The \"" <> unpack attrName <> "\" attribute appears twice in a set."+formatWarning (NotAString expr) =+ "Error: The expression at "+ <> (prettyPrintSourcePos . sourceSpanBegin . exprSpan) expr+ <> " is not a string literal."+formatWarning (NixPrefetchGitFailed exitCode errorOutput) =+ "Error: nix-prefetch-git failed with exit code " <> show exitCode+ <> " and error output:\n" <> unpack errorOutput+formatWarning (InvalidPrefetchGitOutput output) =+ "Error: Output from nix-prefetch-git is invalid:\n" <> show output+formatWarning (InvalidDateString text) =+ "Error: Date string is invalid: " <> show text
+ src/Update/Nix/FetchGit/Warning.hs view
@@ -0,0 +1,15 @@+module Update.Nix.FetchGit.Warning+ ( Warning(..)+ ) where++import Data.Text+import Nix.Expr+import Text.PrettyPrint.ANSI.Leijen (Doc)++data Warning = CouldNotParseInput Doc+ | MissingAttr Text+ | DuplicateAttrs Text+ | NotAString NExprLoc+ | NixPrefetchGitFailed Int Text+ | InvalidPrefetchGitOutput Text+ | InvalidDateString Text
+ src/Update/Span.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | This module deals with updating spans of characters in values of type Text.+--+-- It defines some helper types and functions to apply these "updates".++module Update.Span+ ( SpanUpdate(..)+ , SourcePos(..)+ , SourceSpan(..)+ , updateSpan+ , updateSpans+ , linearizeSourcePos+ , prettyPrintSourcePos+ ) where++import Control.Exception (assert)+import Data.Data (Data)+import Data.Int (Int64)+import Data.List (genericTake, sortOn)+import Data.Monoid ((<>))+import Data.Text (Text, length, lines, splitAt)+import Prelude hiding (length, lines, splitAt)++-- | A position in a text file+data SourcePos = SourcePos{ sourcePosRow :: Int64,+ sourcePosColumn :: Int64+ }+ deriving (Show, Eq, Ord, Data)++-- | A span of characters with a beginning and an end.+--+-- 'spanEnd' must be greater than 'spanBegin'+data SourceSpan = SourceSpan{ sourceSpanBegin :: SourcePos+ , sourceSpanEnd :: SourcePos+ }+ deriving (Show, Data)++-- | A span and some text to replace it with.+-- They don't have to be the same length.+data SpanUpdate = SpanUpdate{ spanUpdateSpan :: SourceSpan+ , spanUpdateContents :: Text+ }+ deriving (Show, Data)++-- | Update many spans in a file. They must be non-overlapping.+updateSpans :: [SpanUpdate] -> Text -> Text+updateSpans us t =+ let sortedSpans = sortOn (sourceSpanBegin . spanUpdateSpan) us+ anyOverlap = any (uncurry overlaps)+ (zip <*> tail $ spanUpdateSpan <$> sortedSpans)+ in+ assert (not anyOverlap)+ (foldr updateSpan t sortedSpans)++-- | Update a single span of characters inside a text value. If you're updating+-- multiples spans it's best to use 'updateSpans'.+updateSpan :: SpanUpdate -> Text -> Text+updateSpan (SpanUpdate (SourceSpan b e) r) t =+ let (before, _) = split b t+ (_, end) = split e t+ in before <> r <> end++-- | Do two spans overlap+overlaps :: SourceSpan -> SourceSpan -> Bool+overlaps (SourceSpan b1 e1) (SourceSpan b2 e2) =+ b2 >= b1 && b2 < e1 || e2 >= b1 && e2 < e1++-- | Split some text at a particular 'SourcePos'+split :: SourcePos -> Text -> (Text, Text)+split (SourcePos row col) t =+ splitAt (fromIntegral (linearizeSourcePos t row col)) t++-- | Go from a line and column representation to a single character offset from+-- the beginning of the text.+--+-- This probably fails on crazy texts with multi character line breaks.+linearizeSourcePos :: Text -- ^ The string to linearize in+ -> Int64 -- ^ The line offset+ -> Int64 -- ^ The column offset+ -> Int64 -- ^ The character offset+linearizeSourcePos t l c = fromIntegral lineCharOffset + c+ where lineCharOffset = sum . fmap ((+1) . length) . genericTake l . lines $ t++prettyPrintSourcePos :: SourcePos -> String+prettyPrintSourcePos (SourcePos row column) =+ "line " <> show row <> " column " <> show column
+ update-nix-fetchgit.cabal view
@@ -0,0 +1,53 @@+name: update-nix-fetchgit+version: 0.1.0.0+synopsis: A program to update fetchgit values in Nix expressions+description: Please see README.md+homepage: https://github.com/expipiplus1/update-nix-fetchgit#readme+license: BSD3+license-file: LICENSE+author: Joe Hermaszewski+maintainer: haskell@monoid.al+copyright: 2015 Joe Hermaszewski+category: Nix+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Update.Nix.FetchGit+ , Update.Span+ , Update.Nix.FetchGit.Prefetch+ , Update.Nix.FetchGit.Warning+ , Update.Nix.FetchGit.Utils+ other-modules: Update.Nix.FetchGit.Types+ build-depends: base >= 4.7 && < 5+ , aeson >= 0.9 && < 0.12+ , ansi-wl-pprint >= 0.6 && < 0.7+ , async >= 2.1 && < 2.2+ , bytestring >= 0.10 && < 0.11+ , data-fix >= 0.0 && < 0.1+ , hnix >= 0.3.2 && < 0.4+ , process >= 1.2 && < 1.5+ , text >= 1.2 && < 1.3+ , time >= 1.5 && < 1.7+ , transformers >= 0.4 && < 0.6+ , trifecta >= 1.6 && < 1.7+ , uniplate >= 1.6 && < 1.7+ , utf8-string >= 1.0 && < 1.1+ , errors >= 2.1 && < 2.2+ default-language: Haskell2010+ ghc-options: -Wall++executable update-nix-fetchgit+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends: base+ , text >= 1.2 && < 1.3+ , update-nix-fetchgit+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/expipiplus1/update-nix-fetchgit