diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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) diff --git a/src/Update/Nix/FetchGit.hs b/src/Update/Nix/FetchGit.hs new file mode 100644 --- /dev/null +++ b/src/Update/Nix/FetchGit.hs @@ -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 diff --git a/src/Update/Nix/FetchGit/Prefetch.hs b/src/Update/Nix/FetchGit/Prefetch.hs new file mode 100644 --- /dev/null +++ b/src/Update/Nix/FetchGit/Prefetch.hs @@ -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) diff --git a/src/Update/Nix/FetchGit/Types.hs b/src/Update/Nix/FetchGit/Types.hs new file mode 100644 --- /dev/null +++ b/src/Update/Nix/FetchGit/Types.hs @@ -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) diff --git a/src/Update/Nix/FetchGit/Utils.hs b/src/Update/Nix/FetchGit/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Update/Nix/FetchGit/Utils.hs @@ -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 diff --git a/src/Update/Nix/FetchGit/Warning.hs b/src/Update/Nix/FetchGit/Warning.hs new file mode 100644 --- /dev/null +++ b/src/Update/Nix/FetchGit/Warning.hs @@ -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 diff --git a/src/Update/Span.hs b/src/Update/Span.hs new file mode 100644 --- /dev/null +++ b/src/Update/Span.hs @@ -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 diff --git a/update-nix-fetchgit.cabal b/update-nix-fetchgit.cabal new file mode 100644 --- /dev/null +++ b/update-nix-fetchgit.cabal @@ -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