New update mechanism

2024-09-05 20:15:26 +03:00 · 2019-06-09 22:42:35 +02:00 · 2019-06-09 22:42:35 +02:00 · 7789b95124
commit 7789b95124
parent 65786ee156
12 changed files with 738 additions and 169 deletions
--- a/app/Niv.hs
+++ b/app/Niv.hs
@ -7,17 +7,20 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}

+module Niv where
+
 import Control.Applicative
 import Control.Monad
 import Control.Monad.State
-import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
+import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.=))
 import Data.Char (isSpace)
 import Data.FileEmbed (embedFile)
-import Data.Functor ((<&>))
 import Data.Hashable (Hashable)
 import Data.Maybe (mapMaybe, fromMaybe)
 import Data.String.QQ (s)
-import GHC.Exts (toList)
+import Niv.GitHub
+import Niv.Test
+import Niv.Update
 import System.Exit (exitFailure)
 import System.FilePath ((</>), takeDirectory)
 import System.Process (readProcess)
@ -31,10 +34,10 @@ import qualified Data.HashMap.Strict as HMS
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified GitHub as GH
-import qualified GitHub.Data.Name as GH
 import qualified Options.Applicative as Opts
 import qualified Options.Applicative.Help.Pretty as Opts
 import qualified System.Directory as Dir
+import qualified Test.Tasty as Tasty

 main :: IO ()
 main = join $ Opts.execParser opts
@ -86,9 +89,13 @@ parsePackageName :: Opts.Parser PackageName
 parsePackageName = PackageName <$>
    Opts.argument Opts.str (Opts.metavar "PACKAGE")

-newtype PackageSpec = PackageSpec { _unPackageSpec :: Aeson.Object }
+newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object }
  deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid)

+-- | Simply discards the 'Freedom'
+attrsToSpec :: Attrs -> PackageSpec
+attrsToSpec = PackageSpec . fmap snd
+
 parsePackageSpec :: Opts.Parser PackageSpec
 parsePackageSpec =
    (PackageSpec . HMS.fromList . fmap fixupAttributes) <$>
@ -126,6 +133,7 @@ parsePackageSpec =
    shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>
      [ "branch", "owner", "repo", "version" ]

+    -- TODO: infer those shortcuts from 'Update' keys
    mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, T.Text)
    mkShortcutAttribute = \case
      attr@(T.uncons -> Just (c,_)) -> (attr,) <$> Opts.strOption
@ -150,113 +158,8 @@ parsePackage = (,) <$> parsePackageName <*> parsePackageSpec
 -- PACKAGE SPEC OPS
 -------------------------------------------------------------------------------

-updatePackageSpec :: PackageSpec -> IO PackageSpec
-updatePackageSpec = execStateT $ do
-    originalUrl <- getPackageSpecAttr "url"
-
-    -- Figures out the URL from the template
-    withPackageSpecAttr "url_template" (\case
-      Aeson.String (T.unpack -> template) -> do
-        packageSpec <- get
-        let stringValues = packageSpecStringValues packageSpec
-        case renderTemplate stringValues template of
-          Just renderedURL ->
-            setPackageSpecAttr "url" (Aeson.String $ T.pack renderedURL)
-          Nothing -> pure ()
-      _ -> pure ()
-      )
-
-    -- If the type attribute is not set, we try to infer its value based on the url suffix
-    (,) <$> getPackageSpecAttr "type" <*> getPackageSpecAttr "url" >>= \case
-      -- If an url type is set, we'll use it
-      (Just _, _) -> pure ()
-      -- We need an url to infer a url type
-      (_, Nothing) -> pure ()
-      (Nothing, Just (Aeson.String url)) -> do
-         let urlType = if "tar.gz" `T.isSuffixOf` url
-                       then "tarball"
-                       else "file"
-         setPackageSpecAttr "type" (Aeson.String $ T.pack urlType)
-      -- If the JSON value is not a string, we ignore it
-      (_, _) -> pure ()
-
-    -- Updates the sha256 based on the URL contents
-    (,) <$> getPackageSpecAttr "url" <*> getPackageSpecAttr "sha256" >>= \case
-      -- If no URL is set, we simply can't prefetch
-      (Nothing, _) -> pure ()
-
-      -- If an URL is set and no sha is set, /do/ update
-      (Just url, Nothing) -> prefetch url
-
-      -- If both the URL and sha are set, update only if the url has changed
-      (Just url, Just{}) -> when (Just url /= originalUrl) (prefetch url)
-  where
-    prefetch :: Aeson.Value -> StateT PackageSpec IO ()
-    prefetch = \case
-      Aeson.String (T.unpack -> url) -> do
-        unpack <- getPackageSpecAttr "type" <&> \case
-          -- Do not unpack if the url type is 'file'
-          Just (Aeson.String urlType) -> not $ T.unpack urlType == "file"
-          _ -> True
-        sha256 <- liftIO $ nixPrefetchURL unpack url
-        setPackageSpecAttr "sha256" (Aeson.String $ T.pack sha256)
-      _ -> pure ()
-
-completePackageSpec
-  :: PackageSpec
-  -> IO (PackageSpec)
-completePackageSpec = execStateT $ do
-
-    -- In case we have @owner@ and @repo@, pull some data from GitHub
-    (,) <$> getPackageSpecAttr "owner" <*> getPackageSpecAttr "repo" >>= \case
-      (Just (Aeson.String owner), Just (Aeson.String repo)) -> do
-          liftIO (GH.executeRequest' $ GH.repositoryR (GH.N owner) (GH.N repo))
-            >>= \case
-              Left e ->
-                liftIO $ warnCouldNotFetchGitHubRepo e (T.unpack owner, T.unpack repo)
-              Right ghRepo -> do
-
-                -- Description
-                whenNotSet "description" $ case GH.repoDescription ghRepo of
-                  Just descr ->
-                    setPackageSpecAttr "description" (Aeson.String descr)
-                  Nothing -> pure ()
-
-                whenNotSet "homepage" $ case GH.repoHomepage ghRepo of
-                  Just descr ->
-                    setPackageSpecAttr "homepage" (Aeson.String descr)
-                  Nothing -> pure ()
-
-                -- Branch and rev
-                whenNotSet "branch" $ case GH.repoDefaultBranch ghRepo of
-                  Just branch ->
-                    setPackageSpecAttr "branch" (Aeson.String branch)
-                  Nothing -> pure ()
-
-                withPackageSpecAttr "branch" (\case
-                  Aeson.String branch -> do
-                    liftIO (GH.executeRequest' $
-                      GH.commitsWithOptionsForR
-                      (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
-                      [GH.CommitQuerySha branch]) >>= \case
-                        Right (toList -> (commit:_)) -> do
-                          let GH.N rev = GH.commitSha commit
-                          setPackageSpecAttr "rev" (Aeson.String rev)
-                        _ -> pure ()
-                  _ -> pure ()
-                  )
-      (_,_) -> pure ()
-
-    -- Figures out the URL template
-    whenNotSet "url_template" $
-      setPackageSpecAttr
-        "url_template"
-        (Aeson.String githubURLTemplate)
-
-  where
-    githubURLTemplate :: T.Text
-    githubURLTemplate =
-      "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+test :: IO ()
+test = Tasty.defaultMain $ Niv.Test.tests

 -------------------------------------------------------------------------------
 -- PackageSpec State helpers
@ -382,18 +285,14 @@ parseCmdAdd =
      ]

 cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO ()
-cmdAdd mPackageName (PackageName str, spec) = do
+cmdAdd mPackageName (PackageName str, cliSpec) = do

    -- Figures out the owner and repo
-    (packageName, spec') <- flip runStateT spec $ case T.span (/= '/') str of
+    let (packageName, defaultSpec) = case T.span (/= '/') str of
          ( owner@(T.null -> False)
            , T.uncons -> Just ('/', repo@(T.null -> False))) -> do
-            whenNotSet "owner" $
-              setPackageSpecAttr "owner" (Aeson.String owner)
-            whenNotSet "repo" $ do
-                setPackageSpecAttr "repo" (Aeson.String repo)
-            pure (PackageName repo)
-          _ -> pure (PackageName str)
+            (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ])
+          _ -> (PackageName str, HMS.empty)

    sources <- unSources <$> getSources

@ -402,7 +301,11 @@ cmdAdd mPackageName (PackageName str, spec) = do
    when (HMS.member packageName' sources) $
      abortCannotAddPackageExists packageName'

-    spec'' <- updatePackageSpec =<< completePackageSpec spec'
+    let defaultSpec' = PackageSpec $ defaultSpec
+
+    spec'' <- attrsToSpec <$> evalUpdate
+      (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec')
+      (githubUpdate nixPrefetchURL githubLatestRev githubRepo)

    putStrLn $ "Writing new sources file"
    setSources $ Sources $
@ -415,6 +318,7 @@ cmdAdd mPackageName (PackageName str, spec) = do
 parseCmdShow :: Opts.ParserInfo (IO ())
 parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc

+-- TODO: nicer output
 cmdShow :: IO ()
 cmdShow = do
    putStrLn $ "Showing sources file"
@ -450,6 +354,13 @@ parseCmdUpdate =
          "  niv update my-package -v beta-0.2"
      ]

+specToFreeAttrs :: PackageSpec -> Attrs
+specToFreeAttrs = fmap (Free,) . unPackageSpec
+
+specToLockedAttrs :: PackageSpec -> Attrs
+specToLockedAttrs = fmap (Locked,) . unPackageSpec
+
+-- TODO: sexy logging + concurrent updates
 cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO ()
 cmdUpdate = \case
    Just (packageName, packageSpec) -> do
@ -458,10 +369,9 @@ cmdUpdate = \case

      packageSpec' <- case HMS.lookup packageName sources of
        Just packageSpec' -> do
-
-          -- TODO: something fishy happening here
-          pkgSpec <- completePackageSpec $ packageSpec <> packageSpec'
-          updatePackageSpec $ pkgSpec
+          attrsToSpec <$> evalUpdate
+            (specToLockedAttrs packageSpec <> specToFreeAttrs packageSpec')
+            (githubUpdate nixPrefetchURL githubLatestRev githubRepo)

        Nothing -> abortCannotUpdateNoSuchPackage packageName

@ -474,7 +384,9 @@ cmdUpdate = \case
      sources' <- forWithKeyM sources $
        \packageName packageSpec -> do
          T.putStrLn $ "Package: " <> unPackageName packageName
-          updatePackageSpec =<< completePackageSpec packageSpec
+          attrsToSpec <$> evalUpdate
+            (specToFreeAttrs packageSpec)
+            (githubUpdate nixPrefetchURL githubLatestRev githubRepo)

      setSources $ Sources sources'

@ -587,31 +499,16 @@ mapWithKeyM_ f m = do
    forM_ (HMS.toList m) $ \(k, v) ->
      HMS.singleton k <$> f k v

-- | Renders the template. Returns 'Nothing' if some of the attributes are
-- missing.
--
--  renderTemplate [("foo", "bar")] "<foo>" == Just "bar"
--  renderTemplate [("foo", "bar")] "<baz>" == Nothing
-renderTemplate :: [(String, String)] -> String -> Maybe String
-renderTemplate vals = \case
-    '<':str -> do
-      case span (/= '>') str of
-        (key, '>':rest) ->
-          liftA2 (<>) (lookup key vals) (renderTemplate vals rest)
-        _ -> Nothing
-    c:str -> (c:) <$> renderTemplate vals str
-    [] -> Just []
-
 abort :: T.Text -> IO a
 abort msg = do
    T.putStrLn msg
    exitFailure

-nixPrefetchURL :: Bool -> String -> IO String
-nixPrefetchURL unpack url =
+nixPrefetchURL :: Bool -> T.Text -> IO T.Text
+nixPrefetchURL unpack (T.unpack -> url) =
    lines <$> readProcess "nix-prefetch-url" args "" >>=
      \case
-        (l:_) -> pure l
+        (l:_) -> pure (T.pack l)
        _ -> abortNixPrefetchExpectedOutput
  where args = if unpack then ["--unpack", url] else [url]

--- a/default.nix
+++ b/default.nix
@ -15,6 +15,11 @@ with rec
    [ "^package.yaml$"
      "^app$"
      "^app.*.hs$"
+      "^src$"
+      "^src/Niv$"
+      "^src/Niv/GitHub$"
+      "^src/Niv/Update$"
+      "^src.*.hs$"
      "^README.md$"
      "^nix$"
      "^nix.sources.nix$"
@ -29,7 +34,8 @@ with rec
      shellHook =
        ''
          repl() {
-            ghci app/Niv.hs
+            shopt -s globstar
+            ghci -Wall app/**/*.hs src/**/*.hs
          }

          echo "To start a REPL session, run:"
@ -94,6 +100,8 @@ rec
      [ $expected_hash == $actual_hash ] && echo dymmy > $out || err
    '';

+
+  # TODO: use nivForTest for this one
  niv-svg-cmds = pkgs.writeScript "niv-svg-cmds"
      ''
        #!${pkgs.stdenv.shell}
--- a/package.yaml
+++ b/package.yaml
@ -6,24 +6,41 @@ ghc-options:
    - -Wall
    - -Werror

-executable:
-    main: app/Niv.hs
+dependencies:
+    - base
+    - text
+    - mtl
+    - unliftio
+
+library:
+    source-dirs:
+        - src
    dependencies:
-        - base
-        - hashable
-        - file-embed
-        - process
-        - text
-        - bytestring
        - aeson
-        - aeson-pretty
-        - directory
-        - string-qq
-        - filepath
        - github
-        - mtl
-        - optparse-applicative
-        - unliftio
+        - tasty
+        - tasty-hunit
        - unordered-containers
-    data-files:
-        - nix/sources.nix
+
+executables:
+    niv:
+        source-dirs:
+            - app
+        main: Niv.main
+        data-files:
+            - nix/sources.nix
+        dependencies:
+            - aeson
+            - aeson-pretty
+            - bytestring
+            - directory
+            - filepath
+            - github
+            - hashable
+            - file-embed
+            - niv
+            - optparse-applicative
+            - process
+            - string-qq
+            - tasty
+            - unordered-containers
--- a/script/test
+++ b/script/test
@ -11,6 +11,6 @@ export NIX_PATH="nixpkgs=./nix"
 echo "Building"

 # Build and create a root
-nix-build --no-link
+nix-build --sandbox --no-link --max-jobs 10

 echo "all good"
--- a/site/niv.svg
+++ b/site/niv.svg
@ -1,10 +1,10 @@
-<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" id="e7be124f4eec8170d74afbc28a4a5f02" baseProfile="full" viewBox="0 0 703 523" width="703" version="1.1">
+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" id="da2b5e7cef46c2eb6a8cb3f6111a7153" baseProfile="full" viewBox="0 0 703 523" width="703" version="1.1">
    <defs>
        <termtosvg:template_settings xmlns:termtosvg="https://github.com/nbedos/termtosvg">
            <termtosvg:screen_geometry columns="82" rows="26"/>
        </termtosvg:template_settings>
        <style type="text/css" id="generated-style"><![CDATA[:root {
-            --animation-duration: 5500ms;
+            --animation-duration: 1000ms;
        }

    #screen {
@ -44,5 +44,5 @@
    <circle cx="44" cy="23" r="7" class="color3"/>
    <circle cx="64" cy="23" r="7" class="color2"/>
    <svg id="screen" width="656" x="23" y="50" viewBox="0 0 656 442" preserveAspectRatio="xMidYMin meet">
-        <rect class="background" height="100%" width="100%" x="0" y="0"/><g display="none"><rect class="foreground" height="17" width="8" x="0" y="85"/><use y="85" xlink:href="#g1"/><animate attributeName="display" begin="0ms; anim_last.end" dur="1500ms" from="inline" to="inline"/></g><g display="none"><rect class="foreground" height="17" width="8" x="0" y="187"/><use y="187" xlink:href="#g1"/><animate attributeName="display" begin="1500ms; anim_last.end+1500ms" dur="1500ms" from="inline" to="inline"/></g><g display="none"><rect class="foreground" height="17" width="8" x="0" y="306"/><use y="306" xlink:href="#g1"/><animate attributeName="display" begin="3000ms; anim_last.end+3000ms" dur="1500ms" from="inline" to="inline"/></g><g display="none"><use y="0" xlink:href="#g2"/><use y="17" xlink:href="#g3"/><use y="34" xlink:href="#g4"/><use y="51" xlink:href="#g5"/><use y="68" xlink:href="#g6"/><animate attributeName="display" begin="0ms; anim_last.end" dur="5500ms" from="inline" to="inline"/></g><g display="none"><use y="85" xlink:href="#g7"/><use y="102" xlink:href="#g8"/><use y="119" xlink:href="#g9"/><use y="136" xlink:href="#g10"/><use y="153" xlink:href="#g11"/><use y="170" xlink:href="#g6"/><animate attributeName="display" begin="1500ms; anim_last.end+1500ms" dur="4000ms" from="inline" to="inline"/></g><g display="none"><use y="272" xlink:href="#g12"/><use y="289" xlink:href="#g6"/><use y="187" xlink:href="#g7"/><use y="204" xlink:href="#g13"/><use y="221" xlink:href="#g14"/><use y="238" xlink:href="#g10"/><animate attributeName="display" begin="3000ms; anim_last.end+3000ms" dur="2500ms" from="inline" to="inline"/></g><g display="none"><use y="306" xlink:href="#g7"/><use y="323" xlink:href="#g15"/><use y="340" xlink:href="#g16"/><use y="357" xlink:href="#g10"/><rect class="foreground" height="17" width="8" x="0" y="374"/><use y="374" xlink:href="#g1"/><animate attributeName="display" begin="4500ms; anim_last.end+4500ms" dur="1000ms" from="inline" to="inline" id="anim_last"/></g><defs><g id="g1"><text class="background" textLength="8" x="0"> </text></g><g id="g2"><text class="foreground" textLength="80" x="0">$ niv init</text></g><g id="g3"><text class="foreground" textLength="192" x="0">Creating nix/sources.nix</text></g><g id="g4"><text class="foreground" textLength="200" x="0">Creating nix/sources.json</text></g><g id="g5"><text class="foreground" textLength="152" x="0">Importing 'niv' ...</text></g><g id="g6"><text class="foreground" textLength="160" x="0">Reading sources file</text></g><g id="g7"><text class="foreground" textLength="96" x="0">unpacking...</text></g><g id="g8"><text class="foreground" textLength="656" x="0">path is '/nix/store/bypafdfyf7q6fg1m1xxps4gv4adwwlxb-2f95c55006d6138aafe44e452350c</text></g><g id="g9"><text class="foreground" textLength="152" x="0">e7fa3211dfd.tar.gz'</text></g><g id="g10"><text class="foreground" textLength="192" x="0">Writing new sources file</text></g><g id="g11"><text class="foreground" textLength="184" x="0">Importing 'nixpkgs' ...</text></g><g id="g12"><text class="foreground" textLength="168" x="0">$ niv add stedolan/jq</text></g><g id="g13"><text class="foreground" textLength="656" x="0">path is '/nix/store/qbzbhgq78m94j4dm026y7mi7nkd4lgh4-a7e559a5504572008567383c3dc8e</text></g><g id="g14"><text class="foreground" textLength="152" x="0">142fa7a8633.tar.gz'</text></g><g id="g15"><text class="foreground" textLength="656" x="0">path is '/nix/store/yjz2v8kfk2jkzc0w7lh43hfmcafpqs33-ad9fc9f559e78a764aac20f669f23</text></g><g id="g16"><text class="foreground" textLength="152" x="0">cdd020cd943.tar.gz'</text></g></defs></svg>
+        <rect class="background" height="100%" width="100%" x="0" y="0"/><g display="none"><use y="0" xlink:href="#g1"/><use y="17" xlink:href="#g2"/><use y="34" xlink:href="#g3"/><use y="51" xlink:href="#g4"/><use y="68" xlink:href="#g5"/><use y="85" xlink:href="#g6"/><use y="102" xlink:href="#g7"/><use y="119" xlink:href="#g8"/><use y="136" xlink:href="#g9"/><use y="153" xlink:href="#g10"/><use y="170" xlink:href="#g11"/><use y="187" xlink:href="#g12"/><use y="204" xlink:href="#g13"/><use y="221" xlink:href="#g14"/><use y="238" xlink:href="#g15"/><use y="255" xlink:href="#g16"/><use y="272" xlink:href="#g17"/><use y="289" xlink:href="#g18"/><use y="306" xlink:href="#g19"/><use y="323" xlink:href="#g20"/><use y="340" xlink:href="#g21"/><use y="357" xlink:href="#g22"/><use y="374" xlink:href="#g23"/><use y="391" xlink:href="#g24"/><use y="408" xlink:href="#g25"/><rect class="foreground" height="17" width="8" x="0" y="425"/><use y="425" xlink:href="#g26"/><animate attributeName="display" begin="0ms; anim_last.end" dur="1000ms" from="inline" to="inline" id="anim_last"/></g><defs><g id="g1"><text class="foreground" textLength="216" x="0">  redirectCount        = 10</text></g><g id="g2"><text class="foreground" textLength="376" x="0">  responseTimeout      = ResponseTimeoutDefault</text></g><g id="g3"><text class="foreground" textLength="264" x="0">  requestVersion       = HTTP/1.1</text></g><g id="g4"><text class="foreground" textLength="8" x="0">}</text></g><g id="g5"><text class="foreground" textLength="656" x="0"> (StatusCodeException (Response {responseStatus = Status {statusCode = 403, status</text></g><g id="g6"><text class="foreground" textLength="656" x="0">Message = "Forbidden"}, responseVersion = HTTP/1.1, responseHeaders = [("Date","Su</text></g><g id="g7"><text class="foreground" textLength="656" x="0">n, 09 Jun 2019 20:58:18 GMT"),("Content-Type","application/json; charset=utf-8"),(</text></g><g id="g8"><text class="foreground" textLength="656" x="0">"Transfer-Encoding","chunked"),("Server","GitHub.com"),("Status","403 Forbidden"),</text></g><g id="g9"><text class="foreground" textLength="656" x="0">("X-RateLimit-Limit","60"),("X-RateLimit-Remaining","0"),("X-RateLimit-Reset","156</text></g><g id="g10"><text class="foreground" textLength="656" x="0">0117498"),("X-GitHub-Media-Type","github.v3; param=preview"),("Access-Control-Expo</text></g><g id="g11"><text class="foreground" textLength="656" x="0">se-Headers","ETag, Link, Location, Retry-After, X-GitHub-OTP, X-RateLimit-Limit, X</text></g><g id="g12"><text class="foreground" textLength="656" x="0">-RateLimit-Remaining, X-RateLimit-Reset, X-OAuth-Scopes, X-Accepted-OAuth-Scopes, </text></g><g id="g13"><text class="foreground" textLength="656" x="0">X-Poll-Interval, X-GitHub-Media-Type"),("Access-Control-Allow-Origin","*"),("Stric</text></g><g id="g14"><text class="foreground" textLength="656" x="0">t-Transport-Security","max-age=31536000; includeSubdomains; preload"),("X-Frame-Op</text></g><g id="g15"><text class="foreground" textLength="656" x="0">tions","deny"),("X-Content-Type-Options","nosniff"),("X-XSS-Protection","1; mode=b</text></g><g id="g16"><text class="foreground" textLength="656" x="0">lock"),("Referrer-Policy","origin-when-cross-origin, strict-origin-when-cross-orig</text></g><g id="g17"><text class="foreground" textLength="656" x="0">in"),("Content-Security-Policy","default-src 'none'"),("Content-Encoding","gzip"),</text></g><g id="g18"><text class="foreground" textLength="656" x="0">("X-GitHub-Request-Id","5B88:5CE6:6ED9B59:8B00C6C:5CFD72EA")], responseBody = (), </text></g><g id="g19"><text class="foreground" textLength="656" x="0">responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}) "{\"message</text></g><g id="g20"><text class="foreground" textLength="656" x="0">\":\"API rate limit exceeded for 31.10.138.2. (But here's the good news: Authentic</text></g><g id="g21"><text class="foreground" textLength="656" x="0">ated requests get a higher rate limit. Check out the documentation for more detail</text></g><g id="g22"><text class="foreground" textLength="656" x="0">s.)\",\"documentation_url\":\"https://developer.github.com/v3/#rate-limiting\"}"))</text></g><g id="g23"><text class="foreground" textLength="240" x="0">CallStack (from HasCallStack):</text></g><g id="g24"><text class="foreground" textLength="656" x="0">  error, called at src/Niv/GitHub.hs:26:17 in niv-0.0.0-JC9JoLR1NiMAj6KwAyJn9X:Niv</text></g><g id="g25"><text class="foreground" textLength="56" x="0">.GitHub</text></g><g id="g26"><text class="background" textLength="8" x="0"> </text></g></defs></svg>
 </svg>
--- a/src/Niv/GitHub.hs
+++ b/src/Niv/GitHub.hs
@ -0,0 +1,97 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Niv.GitHub where
+
+import Control.Arrow
+import Data.Bool
+import Data.Maybe
+import GHC.Exts (toList)
+import Niv.Update
+import qualified Data.Text as T
+import qualified GitHub as GH
+import qualified GitHub.Data.Name as GH
+
+data GithubRepo = GithubRepo
+  { repoDescription :: Maybe T.Text
+  , repoHomepage :: Maybe T.Text
+  , repoDefaultBranch :: Maybe T.Text
+  }
+
+githubRepo :: T.Text -> T.Text -> IO GithubRepo
+githubRepo owner repo = fmap translate <$>
+    GH.executeRequest' (GH.repositoryR (GH.N owner) (GH.N repo)) >>= \case
+      Left e -> error (show e)
+      Right x -> pure x
+  where
+    translate r = GithubRepo
+      { repoDescription = GH.repoDescription r
+      , repoHomepage = GH.repoHomepage r
+      , repoDefaultBranch = GH.repoDefaultBranch r
+      }
+
+-- TODO: fetchers for:
+--  * npm
+--  * hackage
+--  * docker
+--  * ... ?
+githubUpdate
+  :: (Bool -> T.Text -> IO T.Text)
+  -- ^ prefetch
+  -> (T.Text -> T.Text -> T.Text -> IO T.Text)
+  -- ^ latest revision
+  -> (T.Text -> T.Text -> IO GithubRepo)
+  -- ^ get repo
+  -> Update () ()
+githubUpdate prefetch latestRev ghRepo = proc () -> do
+    urlTemplate <- template <<<
+      (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -<
+      ()
+    url <- update "url" -< urlTemplate
+    let isTar = ("tar.gz" `T.isSuffixOf`) <$> url
+    useOrSet "type" -< bool "file" "tarball" <$> isTar :: Box T.Text
+    let doUnpack = isTar
+    _sha256 <- update "sha256" <<< run (\(up, u) -> prefetch up u) -< (,) <$> doUnpack <*> url
+    returnA -< ()
+  where
+    completeSpec :: Update () (Box T.Text)
+    completeSpec = proc () -> do
+      owner <- load "owner" -< ()
+      repo <- load "repo" -< ()
+      repoInfo <- run (\(a, b) -> ghRepo a b) -< (,) <$> owner <*> repo
+      branch <- useOrSet "branch" <<< arr (fmap $ fromMaybe "master") -<
+        repoDefaultBranch <$> repoInfo
+      _description <- useOrSet "description" -< repoDescription <$> repoInfo
+      _homepage <- useOrSet "homepage" -< repoHomepage <$> repoInfo
+      _ <- update "rev" <<< run' (\(a,b,c) -> latestRev a b c) -<
+        (,,) <$> owner <*> repo <*> branch
+      returnA -< pure githubURLTemplate
+
+githubURLTemplate :: T.Text
+githubURLTemplate =
+  "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+
+-- | Get the latest revision for owner, repo and branch.
+-- TODO: explain no error handling
+githubLatestRev
+  :: T.Text
+  -- ^ owner
+  -> T.Text
+  -- ^ repo
+  -> T.Text
+  -- ^ branch
+  -> IO T.Text
+githubLatestRev owner repo branch =
+    GH.executeRequest' (
+      GH.commitsWithOptionsForR (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
+      [GH.CommitQuerySha branch]
+      ) >>= \case
+        Right (toList -> (commit:_)) -> do
+          let GH.N rev = GH.commitSha commit
+          pure $ rev
+        Right (toList -> []) -> do
+          error "No rev: no commits"
+        Left e -> error $ "No rev: " <> show e
+        _ -> error $ "No rev: impossible"
--- a/src/Niv/GitHub/Test.hs
+++ b/src/Niv/GitHub/Test.hs
@ -0,0 +1,136 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Niv.GitHub.Test where
+
+import Control.Monad
+import Niv.GitHub
+import Niv.Update
+import qualified Data.HashMap.Strict as HMS
+
+test_githubInitsProperly :: IO ()
+test_githubInitsProperly = do
+    actualState <- evalUpdate initialState $ proc () ->
+      githubUpdate prefetch latestRev ghRepo -< ()
+    unless ((snd <$> actualState) == expectedState) $
+      error $ "State mismatch: " <> show actualState
+  where
+    prefetch _ _ = pure "some-sha"
+    latestRev _ _ _ = pure "some-rev"
+    ghRepo _ _ = pure GithubRepo
+      { repoDescription = Just "some-descr"
+      , repoHomepage = Just "some-homepage"
+      , repoDefaultBranch = Just "master"
+      }
+    initialState = HMS.fromList
+      [ ("owner", (Free, "nmattia"))
+      , ("repo", (Free, "niv")) ]
+    expectedState = HMS.fromList
+      [ ("owner", "nmattia")
+      , ("repo", "niv")
+      , ("homepage", "some-homepage")
+      , ("description", "some-descr")
+      , ("branch", "master")
+      , ("url", "https://github.com/nmattia/niv/archive/some-rev.tar.gz")
+      , ("rev", "some-rev")
+      , ("sha256", "some-sha")
+      , ("type", "tarball")
+      , ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
+      ]
+
+test_githubUpdates :: IO ()
+test_githubUpdates = do
+    actualState <- evalUpdate initialState $ proc () ->
+      githubUpdate prefetch latestRev ghRepo -< ()
+    unless ((snd <$> actualState) == expectedState) $
+      error $ "State mismatch: " <> show actualState
+  where
+    prefetch _ _ = pure "new-sha"
+    latestRev _ _ _ = pure "new-rev"
+    ghRepo _ _ = pure GithubRepo
+      { repoDescription = Just "some-descr"
+      , repoHomepage = Just "some-homepage"
+      , repoDefaultBranch = Just "master"
+      }
+    initialState = HMS.fromList
+      [ ("owner", (Free, "nmattia"))
+      , ("repo", (Free, "niv"))
+      , ("homepage", (Free, "some-homepage"))
+      , ("description", (Free, "some-descr"))
+      , ("branch", (Free, "master"))
+      , ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz"))
+      , ("rev", (Free, "some-rev"))
+      , ("sha256", (Free, "some-sha"))
+      , ("type", (Free, "tarball"))
+      , ("url_template", (Free, "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"))
+      ]
+    expectedState = HMS.fromList
+      [ ("owner", "nmattia")
+      , ("repo", "niv")
+      , ("homepage", "some-homepage")
+      , ("description", "some-descr")
+      , ("branch", "master")
+      , ("url", "https://github.com/nmattia/niv/archive/new-rev.tar.gz")
+      , ("rev", "new-rev")
+      , ("sha256", "new-sha")
+      , ("type", "tarball")
+      , ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
+      ]
+
+test_githubDoesntOverrideRev :: IO ()
+test_githubDoesntOverrideRev = do
+    actualState <- evalUpdate initialState $ proc () ->
+      githubUpdate prefetch latestRev ghRepo -< ()
+    unless ((snd <$> actualState) == expectedState) $
+      error $ "State mismatch: " <> show actualState
+  where
+    prefetch _ _ = pure "new-sha"
+    latestRev _ _ _ = error "shouldn't fetch rev"
+    ghRepo _ _ = error "shouldn't fetch repo"
+    initialState = HMS.fromList
+      [ ("owner", (Free, "nmattia"))
+      , ("repo", (Free, "niv"))
+      , ("homepage", (Free, "some-homepage"))
+      , ("description", (Free, "some-descr"))
+      , ("branch", (Free, "master"))
+      , ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz"))
+      , ("rev", (Locked, "custom-rev"))
+      , ("sha256", (Free, "some-sha"))
+      , ("type", (Free, "tarball"))
+      , ("url_template", (Free, "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"))
+      ]
+    expectedState = HMS.fromList
+      [ ("owner", "nmattia")
+      , ("repo", "niv")
+      , ("homepage", "some-homepage")
+      , ("description", "some-descr")
+      , ("branch", "master")
+      , ("url", "https://github.com/nmattia/niv/archive/custom-rev.tar.gz")
+      , ("rev", "custom-rev")
+      , ("sha256", "new-sha")
+      , ("type", "tarball")
+      , ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
+      ]
+
+-- TODO: HMS diff for test output
+test_githubURLFallback :: IO ()
+test_githubURLFallback = do
+    actualState <- evalUpdate initialState $ proc () ->
+      githubUpdate prefetch latestRev ghRepo -< ()
+    unless ((snd <$> actualState) == expectedState) $
+      error $ "State mismatch: " <> show actualState
+  where
+    prefetch _ _ = pure "some-sha"
+    latestRev _ _ _ = error "shouldn't fetch rev"
+    ghRepo _ _ = error "shouldn't fetch repo"
+    initialState = HMS.fromList
+      [ ("url_template", (Free, "https://foo.com/<baz>.tar.gz"))
+      , ("baz", (Free, "tarball"))
+      ]
+    expectedState = HMS.fromList
+      [ ("url_template", "https://foo.com/<baz>.tar.gz")
+      , ("baz", "tarball")
+      , ("url", "https://foo.com/tarball.tar.gz")
+      , ("sha256", "some-sha")
+      , ("type", "tarball")
+      ]
--- a/src/Niv/Test.hs
+++ b/src/Niv/Test.hs
@ -0,0 +1,26 @@
+module Niv.Test (tests) where
+
+import Niv.GitHub.Test
+import Niv.Update.Test
+import qualified Test.Tasty as Tasty
+import qualified Test.Tasty.HUnit as Tasty
+
+tests :: Tasty.TestTree
+tests = Tasty.testGroup "niv"
+    [ Tasty.testGroup "update"
+        [ Tasty.testCase "simply runs" simplyRuns
+        , Tasty.testCase "picks first" picksFirst
+        , Tasty.testCase "loads" loads
+        , Tasty.testCase "survives checks" survivesChecks
+        , Tasty.testCase "isn't too eager" isNotTooEager
+        , Tasty.testCase "dirty forces update" dirtyForcesUpdate
+        , Tasty.testCase "should run when no changes" shouldNotRunWhenNoChanges
+        , Tasty.testCase "templates expand" templatesExpand
+        ]
+    , Tasty.testGroup "github"
+        [ Tasty.testCase "inits properly" test_githubInitsProperly
+        , Tasty.testCase "updates" test_githubUpdates
+        , Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev
+        , Tasty.testCase "falls back to URL" test_githubURLFallback
+        ]
+    ]
--- a/src/Niv/Update.hs
+++ b/src/Niv/Update.hs
@ -0,0 +1,269 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Niv.Update where
+
+import Control.Applicative
+import Control.Arrow
+import Data.Aeson (FromJSON, ToJSON, Value)
+import Data.String
+import UnliftIO
+import qualified Control.Category as Cat
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HMS
+import qualified Data.Text as T
+
+type JSON a = (ToJSON a, FromJSON a)
+
+data UpdateFailed
+  = FailNoSuchKey T.Text
+  | FailBadIo SomeException
+  | FailZero
+  | FailCheck
+  | FailTemplate T.Text [T.Text]
+  deriving Show
+
+data UpdateRes a b
+  = UpdateReady (UpdateReady b)
+  | UpdateNeedMore (a -> IO (UpdateReady b))
+  deriving Functor
+
+data UpdateReady b
+  = UpdateSuccess BoxedAttrs b
+  | UpdateFailed UpdateFailed
+  deriving Functor
+
+execUpdate :: Attrs -> Update () a -> IO a
+execUpdate attrs a = snd <$> runUpdate attrs a
+
+evalUpdate :: Attrs -> Update () a -> IO Attrs
+evalUpdate attrs a = fst <$> runUpdate attrs a
+
+runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
+runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed
+  where
+    feed = \case
+      UpdateReady res -> hndl res
+      UpdateNeedMore next -> next (()) >>= hndl
+    hndl = \case
+      UpdateSuccess f v -> (,v) <$> unboxAttrs f
+      UpdateFailed e -> error $ "baaaah: " <> show e
+
+runBox :: Box a -> IO a
+runBox = boxOp
+
+instance ArrowZero Update where
+    zeroArrow = Zero
+
+instance ArrowPlus Update where
+    (<+>) = Plus
+
+instance Arrow Update where
+    arr = Arr
+    first = First
+
+data Update b c where
+  Id :: Update a a
+  Compose :: (Compose b c) -> Update b c
+  Arr :: (b -> c) -> Update b c
+  First :: Update b c -> Update (b, d) (c, d)
+  Zero :: Update b c
+  Plus :: Update b c -> Update b c -> Update b c
+  Check :: (a -> Bool) -> Update (Box a) ()
+  Load :: T.Text -> Update () (Box Value)
+  UseOrSet :: T.Text -> Update (Box Value) (Box Value)
+  Update :: T.Text -> Update (Box Value) (Box Value)
+  Run :: (a -> IO b)  -> Update (Box a) (Box b)
+  Template :: Update (Box T.Text) (Box T.Text)
+
+instance Cat.Category Update where
+    id = Id
+    f . g = Compose (Compose' f g)
+
+data Compose a c = forall b. Compose' (Update b c) (Update a b)
+
+data Box a = Box
+  { boxNew :: Bool
+  , boxOp :: IO a
+  }
+  deriving Functor
+
+instance Applicative Box where
+  pure x = Box { boxNew = False, boxOp = pure x }
+  f <*> v = Box
+    { boxNew = (||) (boxNew f) (boxNew v)
+    , boxOp = boxOp f <*> boxOp v
+    }
+
+instance Semigroup a => Semigroup (Box a) where
+  (<>) = liftA2 (<>)
+
+instance IsString (Box T.Text) where
+  fromString str = Box { boxNew = False, boxOp = pure $ T.pack str }
+
+instance Show (Update b c) where
+  show = \case
+    Id -> "Id"
+    Compose (Compose' f g)-> "(" <> show f <> " . " <> show g <> ")"
+    Arr _f -> "Arr"
+    First a -> "First " <> show a
+    Zero -> "Zero"
+    Plus l r -> "(" <> show l <> " + " <> show r <> ")"
+    Check _ch -> "Check"
+    Load k -> "Load " <> T.unpack k
+    UseOrSet k -> "UseOrSet " <> T.unpack k
+    Update k -> "Update " <> T.unpack k
+    Run _act -> "Io"
+    Template -> "Template"
+
+type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value)
+type Attrs = HMS.HashMap T.Text (Freedom, Value)
+
+unboxAttrs :: BoxedAttrs -> IO Attrs
+unboxAttrs = traverse (\(fr, v) -> (fr,) <$> runBox v)
+
+boxAttrs :: Attrs -> BoxedAttrs
+boxAttrs = fmap (\(fr, v) -> (fr,
+    case fr of
+      -- TODO: explain why hacky
+      Locked -> (pure v) { boxNew = True } -- XXX: somewhat hacky
+      Free -> pure v
+    ))
+
+data Freedom
+  = Locked
+  | Free
+  deriving (Eq, Show)
+
+-- TODO: tryAny all IOs
+runUpdate' :: BoxedAttrs -> Update a b -> IO (UpdateRes a b)
+runUpdate' attrs = \case
+    Id -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs
+    Arr f -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs . f
+    Zero -> pure $ UpdateReady (UpdateFailed FailZero)
+    Plus l r -> runUpdate' attrs l >>= \case
+      UpdateReady (UpdateFailed{}) -> runUpdate' attrs r
+      UpdateReady (UpdateSuccess f v) -> pure $ UpdateReady (UpdateSuccess f v)
+      UpdateNeedMore next -> pure $ UpdateNeedMore $ \v -> next v >>= \case
+        UpdateSuccess f res -> pure $ UpdateSuccess f res
+        UpdateFailed {} -> runUpdate' attrs r >>= \case
+          UpdateReady res -> pure res
+          UpdateNeedMore next' -> next' v
+    Load k -> pure $ UpdateReady $ do
+      case HMS.lookup k attrs of
+        Just (_, v') -> UpdateSuccess attrs v'
+        Nothing -> UpdateFailed $ FailNoSuchKey k
+    First a -> do
+      runUpdate' attrs a >>= \case
+        UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
+        UpdateReady (UpdateSuccess fo ba) -> pure $ UpdateNeedMore $ \gtt -> do
+          pure $ UpdateSuccess fo (ba, snd gtt)
+        UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do
+          next (fst gtt) >>= \case
+            UpdateFailed e -> pure $ UpdateFailed e
+            UpdateSuccess f res -> do
+              pure $ UpdateSuccess f (res, snd gtt)
+    Run act -> pure (UpdateNeedMore $ \gtt -> do
+      pure $ UpdateSuccess attrs $ Box (boxNew gtt) (act =<< runBox gtt))
+    Check ch -> pure (UpdateNeedMore $ \gtt -> do
+      v <- runBox gtt
+      if ch v
+      then pure $ UpdateSuccess attrs ()
+      else pure $ UpdateFailed FailCheck)
+    UseOrSet k -> pure $ case HMS.lookup k attrs of
+      Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
+      Just (Free, v) -> UpdateReady $ UpdateSuccess attrs v
+      Nothing -> UpdateNeedMore $ \gtt -> do
+        let attrs' = HMS.singleton k (Locked, gtt) <> attrs
+        pure $ UpdateSuccess attrs' gtt
+    Update k -> pure $ case HMS.lookup k attrs of
+      Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
+      Just (Free, v) -> UpdateNeedMore $ \gtt -> do
+        if (boxNew gtt)
+        then pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt
+        else pure $ UpdateSuccess attrs v
+      Nothing -> UpdateNeedMore $ \gtt -> do
+        pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt
+    Compose (Compose' f g) -> runUpdate' attrs g >>= \case
+      UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
+      UpdateReady (UpdateSuccess attrs' act) -> runUpdate' attrs' f >>= \case
+        UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
+        UpdateReady (UpdateSuccess attrs'' act') -> pure $ UpdateReady $ UpdateSuccess attrs'' act'
+        UpdateNeedMore next -> UpdateReady <$> next act
+      UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do
+        next gtt >>= \case
+          UpdateFailed e -> pure $ UpdateFailed e
+          UpdateSuccess attrs' act -> runUpdate' attrs' f >>= \case
+            UpdateReady ready -> pure ready
+            UpdateNeedMore next' -> next' act
+    Template -> pure $ UpdateNeedMore $ \v -> do
+      v' <- runBox v
+      case renderTemplate (\k -> (decodeBox . snd) <$> HMS.lookup k attrs) v' of
+        Nothing -> pure $ UpdateFailed $ FailTemplate v' (HMS.keys attrs)
+        Just v'' -> pure $ UpdateSuccess attrs (v'' <* v) -- carries over v's newness
+
+decodeBox :: FromJSON a => Box Value -> Box a
+decodeBox v = v { boxOp = boxOp v >>= decodeValue }
+
+decodeValue :: FromJSON a => Value -> IO a
+decodeValue v = case Aeson.fromJSON v of
+  Aeson.Success x -> pure x
+  Aeson.Error str -> error $ "Could not decode: " <> show v <> " :" <> str
+
+-- | Renders the template. Returns 'Nothing' if some of the attributes are
+-- missing.
+--  TODO: fix doc
+--  renderTemplate [("foo", "bar")] "<foo>" == pure (Just "bar")
+--  renderTemplate [("foo", "bar")] "<baz>" == pure Nothing
+renderTemplate :: (T.Text -> Maybe (Box T.Text)) -> T.Text -> Maybe (Box T.Text)
+renderTemplate vals = \case
+    (T.uncons -> Just ('<', str)) -> do
+      case T.span (/= '>') str of
+        (key, T.uncons -> Just ('>', rest)) -> do
+          let v = vals key
+          (liftA2 (<>) v) (renderTemplate vals rest)
+        _ -> Nothing
+    (T.uncons -> Just (c, str)) -> fmap (T.cons c) <$> renderTemplate vals str
+    (T.uncons -> Nothing) -> Just $ pure T.empty
+    -- XXX: isn't this redundant?
+    _ -> Just $ pure T.empty
+
+
+template :: Update (Box T.Text) (Box T.Text)
+template = Template
+
+check :: (a -> Bool) -> Update (Box a) ()
+check = Check
+
+load :: FromJSON a => T.Text -> Update () (Box a)
+load k = Load k >>> arr decodeBox
+
+-- TODO: should input really be Box?
+useOrSet :: JSON a => T.Text -> Update (Box a) (Box a)
+useOrSet k =
+    arr (fmap Aeson.toJSON) >>>
+    UseOrSet k >>>
+    arr decodeBox
+
+update :: JSON a => T.Text -> Update (Box a) (Box a)
+update k =
+    arr (fmap Aeson.toJSON) >>>
+    Update k >>>
+    arr decodeBox
+
+run :: (a -> IO b) -> Update (Box a) (Box b)
+run = Run
+
+-- | Like 'run' but forces evaluation
+run' :: (a -> IO b) -> Update (Box a) (Box b)
+run' act = Run act >>> dirty
+
+dirty :: Update (Box a) (Box a)
+dirty = arr (\v -> v { boxNew = True })
--- a/src/Niv/Update/Test.hs
+++ b/src/Niv/Update/Test.hs
@ -0,0 +1,114 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Niv.Update.Test where
+
+import Control.Arrow
+import Control.Monad
+import Niv.Update
+import qualified Data.HashMap.Strict as HMS
+import qualified Data.Text as T
+
+simplyRuns :: IO ()
+simplyRuns =
+    void $ runUpdate attrs $ proc () -> do
+      returnA -< ()
+  where
+    attrs = HMS.empty
+
+picksFirst :: IO ()
+picksFirst = do
+    v <- execUpdate HMS.empty $
+      let
+        l = proc () -> do returnA -< 2
+        r = proc () -> do returnA -< 3
+      in l <+> r
+    unless (v == (2::Int)) (error "bad value")
+
+loads :: IO ()
+loads = do
+    v <- execUpdate attrs $ load "foo"
+    v' <- runBox v
+    unless (v' == ("bar" :: T.Text)) (error "bad value")
+  where
+    attrs = HMS.singleton "foo" (Locked, "bar")
+
+survivesChecks :: IO ()
+survivesChecks = do
+    v <- execUpdate attrs $ proc () -> do
+      (sawLeft <+> sawRight) -< ()
+      load "res" -< ()
+    v' <- runBox v
+    unless (v' == ("I saw right" :: T.Text)) (error "bad value")
+  where
+    attrs = HMS.singleton "val" (Locked, "right")
+    sawLeft :: Update () ()
+    sawLeft = proc () -> do
+      val <- load "val" -< ()
+      check (== "left") -< (val :: Box T.Text)
+      useOrSet "res" -< "I saw left" :: Box T.Text
+      returnA -< ()
+    sawRight :: Update () ()
+    sawRight = proc () -> do
+      val <- load "val" -< ()
+      check (== "right") -< (val :: Box T.Text)
+      useOrSet "res" -< "I saw right" :: Box T.Text
+      returnA -< ()
+
+isNotTooEager :: IO ()
+isNotTooEager = do
+    let f = constBox () >>>
+              run (const $ error "IO is too eager (f)") >>>
+              useOrSet "foo"
+    let f1 = proc () -> do
+              run (const $ error "IO is too eager (f1)") -< pure ()
+              useOrSet "foo" -< "foo"
+    void $ (execUpdate attrs f :: IO (Box T.Text))
+    void $ (execUpdate attrs f1 :: IO (Box T.Text))
+  where
+    attrs = HMS.singleton "foo" (Locked, "right")
+
+dirtyForcesUpdate :: IO ()
+dirtyForcesUpdate = do
+    let f = constBox ("world" :: T.Text) >>> dirty >>> update "hello"
+    attrs' <- evalUpdate attrs f
+    unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
+      error $ "bad value for hello: " <> show attrs'
+  where
+    attrs = HMS.singleton "hello" (Free, "foo")
+
+shouldNotRunWhenNoChanges :: IO ()
+shouldNotRunWhenNoChanges = do
+    let f = proc () -> do
+          update "hello" -< ("world" :: Box T.Text)
+          run (\() -> error "io shouldn't be run") -< pure ()
+    attrs <- evalUpdate HMS.empty f
+    unless ((snd <$> HMS.lookup "hello" attrs) == Just "world") $
+      error $ "bad value for hello: " <> show attrs
+    let f' = proc () -> do
+          run (\() -> error "io shouldn't be run") -< pure ()
+          update "hello" -< ("world" :: Box T.Text)
+    attrs' <- evalUpdate HMS.empty f'
+    unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
+      error $ "bad value for hello: " <> show attrs'
+    v3 <- execUpdate
+      (HMS.fromList [("hello", (Free, "world")), ("bar", (Free, "baz"))]) $
+      proc () -> do
+          v1 <- update "hello" -< "world"
+          v2 <- run (\_ -> error "io shouldn't be run") -< (v1 :: Box T.Text)
+          v3 <- update "bar" -< (v2 :: Box T.Text)
+          returnA -< v3
+    v3' <- runBox v3
+    unless (v3' == "baz") $ error "bad value"
+
+templatesExpand :: IO ()
+templatesExpand = do
+    v3 <- execUpdate attrs $ proc () -> template -< "<v1>-<v2>"
+    v3' <- runBox v3
+    unless (v3' == "hello-world") $ error "bad value"
+  where
+    attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))]
+
+constBox :: a -> Update () (Box a)
+constBox a = arr (const (pure a))
--- a/tests/default.nix
+++ b/tests/default.nix
@ -22,8 +22,8 @@ let
    # TODO: Remove this patch by adding an argument to the github
    # subcommand to support GitHub entreprise.
    prePatch = ''
-      sed "s|GH.executeRequest'|GH.executeRequest (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i app/Niv.hs
-      sed "s|https://github.com|http://localhost:3333|" -i app/Niv.hs
+      sed "s|GH.executeRequest'|GH.executeRequest (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i src/Niv/GitHub.hs
+      sed "s|https://github.com|http://localhost:3333|" -i src/Niv/GitHub.hs
    '';
  });
 in pkgs.runCommand "test"
@ -75,7 +75,11 @@ in pkgs.runCommand "test"
      mock/NixOS/nixpkgs-channels/archive/${nixpkgs-channels_HEAD}.tar.gz

    niv init
-    diff -h ${./expected/niv-init.json} nix/sources.json
+    diff -h ${./expected/niv-init.json} nix/sources.json || \
+      (echo "Mismatched sources.json"; \
+      echo "Reference: tests/expected/niv-init.json"; \
+      exit 1)
+
    echo "*** ok."


--- a/tests/expected/niv-init.json
+++ b/tests/expected/niv-init.json
@ -1,5 +1,6 @@
 {
    "nixpkgs": {
+        "homepage": null,
        "url": "http://localhost:3333/NixOS/nixpkgs-channels/archive/571b40d3f50466d3e91c1e609d372de96d782793.tar.gz",
        "owner": "NixOS",
        "branch": "nixos-18.09",