git-remote-ipfs (empty) → 0.1.0.0
raw patch · 14 files changed
+2233/−0 lines, 14 filesdep +aesondep +asyncdep +attoparsec
Dependencies added: aeson, async, attoparsec, base, bytestring, conduit, conduit-extra, cryptonite, entropy, filepath, formatting, generics-sop, git, git-remote-ipfs, hourglass, http-client, ipfs-api, ipld-cid, lens, lens-aeson, mtl, multibase, multihash-cryptonite, network-uri, optparse-applicative, primitive, safe-exceptions, servant, servant-client, stm, tasty, tasty-hunit, temporary, text, transformers, typed-process, unordered-containers, vector
Files
- CHANGELOG.md +0/−0
- LICENSE +30/−0
- README.rst +154/−0
- exe/git-remote-ipfs/Main.hs +78/−0
- git-remote-ipfs.cabal +147/−0
- src/Network/IPFS/Git/RemoteHelper.hs +375/−0
- src/Network/IPFS/Git/RemoteHelper/Client.hs +401/−0
- src/Network/IPFS/Git/RemoteHelper/Command.hs +112/−0
- src/Network/IPFS/Git/RemoteHelper/Format.hs +47/−0
- src/Network/IPFS/Git/RemoteHelper/Generic.hs +81/−0
- src/Network/IPFS/Git/RemoteHelper/Internal.hs +93/−0
- src/Network/IPFS/Git/RemoteHelper/Options.hs +167/−0
- src/Network/IPFS/Git/RemoteHelper/Trans.hs +325/−0
- test/e2e/Main.hs +223/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Monadic GmbH++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 Monadic GmbH 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.
+ README.rst view
@@ -0,0 +1,154 @@+Haskell implementation of a `git remote helper`_ to store git repositories on+IPFS_.++Reverse-engineered from the `Go implementation`_, usable as both an executable+and a library. Future development is going to focus on the latter.++.. _git remote helper: https://git-scm.com/docs/git-remote-helpers+.. _IPFS: https://ipfs.io+.. _Go implementation: https://github.com/ipfs-shipyard/git-remote-ipld++.. contents::+ :local:+ :backlinks: none++Install+================================================================================++1. Build the ``git-remote-ipfs`` executable using either ``stack install`` or+ ``cabal v2-install`` (requires ``cabal-install`` >= 2.4.0.0).++2. Make sure the executable is on your ``$PATH``:+ ``export PATH=$HOME/.local/bin:$PATH``, respectively+ ``export PATH=$HOME/.cabal/bin:$PATH``++3. Download and install the go-ipfs_ binary, and make sure the ipfs daemon is+ running.++.. _go-ipfs: https://docs.ipfs.io/introduction/install/++Usage+================================================================================++To push a (branch of an) existing git repo to IPFS, using `.git/config` to+keep track of pushes:++.. code:: shell++ $ # Add a new remote+ $ git remote add ipfs ipfs://+ $ # Push master+ $ git push ipfs master+ $ # Inspect the IPFS path+ $ git remote get-url ipfs+ ipfs://ipfs/Qm....++Note that every push yields a new IPFS hash. The remote helper will rewrite the+remote URL locally to keep track of the latest remote refs. To collaborate with+other people (i.e. clone/pull from another machine), this URL needs to be+communicated out-of-band. The output of `git remote get-url` can be used to `git+clone`.++An alternative is to use IPNS_, which provides a stable name the remote helper+can update whenever the remote refs are updated:++.. _IPNS: https://docs.ipfs.io/guides/concepts/ipns/++.. code:: shell++ $ repoid=$(ipfs key gen --type=ed25519 myrepo)+ $ # Publish a pointer to the empty directory initially+ $ ipfs name publish --key $repoid QmUNLLsPACCz1vLxQVkXqqLX5R1X345qqfHbsf67hvA3Nn+ $ git remote add ipns ipfs://ipns/$repoid++Note that resolving and updating an IPNS name is rather slow on the main IPFS+network. Also note that only the owner of the IPNS name (that is, the keypair)+can update it.++Configuration+--------------------------------------------------------------------------------++A number of options regarding IPFS can be configured via git-config_:++* ``ipfs.apiurl``++ The URL of the IPFS daemon, default: ``http://localhost:5001``++* ``ipfs.maxconnections``++ The max number of connections to open to the IPFS daemon, default: ``30``++* ``ipfs.maxblocksize``++ The maximum block size (in bytes) supported by bitswap. Most users will+ **not** want to change this. Default: ``2048000``++The API URL can be overriden per-remote using the key+``remote.<remote name>.ipfsapiurl``, e.g.:++.. code:: shell++ $ git config remote.origin.ipfsapiurl http://127.0.0.2:5001++Additionally, if the environment variable ``IPFS_API_URL`` is set, it will be+used instead of any git-config_ settings.++.. _git-config: https://git-scm.com/docs/git-config++How it works+================================================================================++IPFS blocks can be created with the ``git-raw`` CID format, which allows IPFS to+interpret the data as loose git objects. When created with ``sha1`` as the+(multihash) hash function, the block's CID corresponds to the SHA1 hash of the+git object, i.e. one can be recovered from the other. Crucially, this allows the+SHA1 references embedded in a loose git object (eg. parents and tree of a+commit) to be traversed given a head reference.++In order to obtain the head reference, IPLD links are created corresponding to+the ``refs/heads`` directory hierarchy. Note that adding links to an IPFS object+changes its hash - this means each push results in a new object (CID),+which must be retained in order to clone or pull.++Which git objects need to be pushed or fetched is determined via the `git remote+helper`_ protocol, respectively by inspecting the local git repo and remote+refs.++Limitations+--------------------------------------------------------------------------------++* It is currently unclear how to keep track of the latest "anchor" object (the+ one linking to the most recent heads). The obvious solution is to to use IPFS'+ native name resolution mechanism (IPNS), yet IPNS names have a `very limited+ lifetime <https://discuss.ipfs.io/t/ipns-max-lifetime/2130>`_ on the main IPFS+ network.++* IPFS blocks have a maximum size of 2MB. To work around this limitation,+ objects exceeding this limit are created as regular IPFS objects, linked back+ to the "anchor" object under the ``objects/`` hierarchy. When fetching, those+ large objects are given precedence over blocks, so as to not stall forever+ attempting to fetch blocks which the network does not replicate.++* The approach to keep all git objects content-addressable in IPFS is nice+ conceptually, but terribly inefficient: regular git resorts to packfiles_,+ which use delta encoding and compression in order to obtain a more+ space-efficient on-disk and wire format. There is, however, no global optimum+ of how to pack any given git repo, and in fact git re-packs occasionally, as+ it sees fit. It is thus unclear how to optimise git storage in a fully+ distributed setting lacking online coordination.++.. _packfiles: https://git-scm.com/book/en/v2/Git-Internals-Packfiles++Testing+================================================================================++The project employs an end-to-end test suite, which is disabled by default as it+requires a running IPFS daemon. The preferred way to run it is against a local+IPFS network, as this speeds up IPNS resolution considerably.++.. code:: shell++ $ docker run --detach --rm --name=ipfs-test-network --publish 19301:5001 \+ gcr.io/opensourcecoin/ipfs-test-network+ $ IPFS_API_URL=http://127.0.0.1:19301 \+ stack test --flag git-remote-ipfs:with-e2e-tests git-remote-ipfs
+ exe/git-remote-ipfs/Main.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.Attoparsec.ByteString (parseOnly)+import qualified Data.ByteString.Char8 as C8+import Data.Conduit (runConduit, (.|))+import Data.Conduit.Binary (sinkHandle, sourceHandle)+import qualified Data.Conduit.Combinators as Conduit+import Data.Foldable (for_)+import Data.IORef (readIORef)+import Data.Text (Text)+import qualified Data.Text as Text (pack)+import qualified Data.Text.IO as Text (hPutStrLn)+import Options.Applicative+import System.Exit (exitFailure, exitSuccess)+import System.IO+ ( BufferMode(LineBuffering)+ , hSetBuffering+ , stderr+ , stdin+ , stdout+ )++import Network.IPFS.Git.RemoteHelper+import Network.IPFS.Git.RemoteHelper.Command+import Network.IPFS.Git.RemoteHelper.Options+import Network.IPFS.Git.RemoteHelper.Trans++data Error+ = ParseError String+ | ProcError ProcessError++instance DisplayError Error where+ displayError = renderError++renderError :: Error -> Text+renderError = \case+ ParseError e -> "Command failed to parse: " <> Text.pack e+ ProcError e -> renderProcessError e++main :: IO ()+main = do+ for_ [stdin, stdout, stderr] $ flip hSetBuffering LineBuffering++ opt <- execParser optInfo+ env <- newEnv defaultLogger opt =<< getIpfsOptions opt+ res <-+ runRemoteHelper env . runConduit $+ sourceHandle stdin+ .| Conduit.linesUnboundedAscii+ .| Conduit.filter (/= "") -- XXX: batching not supported yet+ .| trace "> "+ .| Conduit.mapM run+ .| Conduit.map renderCommandResult+ .| Conduit.encodeUtf8+ .| trace "< "+ .| sinkHandle stdout++ case res of+ Left e -> Text.hPutStrLn stderr (displayError e) *> exitFailure+ Right _ -> exitSuccess+ where+ optInfo = info (helper <*> parseOptions) fullDesc++ trace prefix = Conduit.mapM $ \x -> do+ v <- liftIO . readIORef =<< asks envVerbosity+ when (v > 1) $+ liftIO (C8.hPutStr stderr prefix *> C8.hPutStrLn stderr x)+ pure x++ run bs = do+ cmd <- either (throwRH . ParseError) pure $ parseOnly parseCommand bs+ mapError ProcError $ processCommand cmd
+ git-remote-ipfs.cabal view
@@ -0,0 +1,147 @@+cabal-version: 2.2+build-type: Simple++name: git-remote-ipfs+version: 0.1.0.0+synopsis: Git remote helper to store git objects on IPFS+homepage: https://github.com/oscoin/ipfs+bug-reports: https://github.com/oscoin/ipfs/issues+license: BSD-3-Clause+license-file: LICENSE+author: Kim Altintop+maintainer: Kim Altintop <kim@monadic.xyz>, Monadic Team <team@monadic.xyz>+copyright: 2018 Monadic GmbH++category: Network++extra-source-files:+ CHANGELOG.md+ , README.rst++source-repository head+ type: git+ location: https://github.com/oscoin/ipfs++flag with-e2e-tests+ description: Build end-to-end test suite+ default: False+ manual: True++common common+ default-language: Haskell2010+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ -fprint-expanded-synonyms+ -funbox-small-strict-fields++ default-extensions:+ BangPatterns+ DeriveGeneric+ LambdaCase+ MultiWayIf+ NamedFieldPuns+ RecordWildCards+ StrictData+ TupleSections+ TypeApplications++library+ import: common+ hs-source-dirs: src++ exposed-modules:+ Network.IPFS.Git.RemoteHelper+ Network.IPFS.Git.RemoteHelper.Client+ Network.IPFS.Git.RemoteHelper.Command+ Network.IPFS.Git.RemoteHelper.Format+ Network.IPFS.Git.RemoteHelper.Generic+ Network.IPFS.Git.RemoteHelper.Internal+ Network.IPFS.Git.RemoteHelper.Options+ Network.IPFS.Git.RemoteHelper.Trans++ build-depends:+ aeson+ , async >= 2.1.1+ , attoparsec+ , base >= 4.9 && < 5+ , bytestring+ , conduit >= 1.3+ , cryptonite+ , filepath+ , formatting+ , generics-sop+ , git >= 0.3.0+ , http-client+ , ipfs-api+ , ipld-cid+ , lens+ , lens-aeson+ , mtl+ , multibase+ , multihash-cryptonite+ , network-uri+ , optparse-applicative+ , primitive+ , safe-exceptions+ , servant+ , servant-client >= 0.15+ , stm >= 2.5+ , text+ , transformers+ , typed-process+ , unordered-containers+ , vector++executable git-remote-ipfs+ import: common+ main-is: Main.hs+ hs-source-dirs: exe/git-remote-ipfs++ build-depends:+ attoparsec+ , base+ , bytestring+ , conduit+ , conduit-extra+ , git-remote-ipfs+ , mtl+ , optparse-applicative+ , text++ ghc-options: -threaded -rtsopts "-with-rtsopts=-maxN4 -A8m"++test-suite e2e-tests+ import: common++ if flag(with-e2e-tests)+ buildable: True+ else+ buildable: False++ main-is: Main.hs+ hs-source-dirs: test/e2e+ type: exitcode-stdio-1.0++ build-depends:+ base+ , bytestring+ , entropy+ , filepath+ , git >= 0.3.0+ , hourglass+ , http-client+ , ipfs-api+ , lens+ , lens-aeson+ , safe-exceptions+ , servant+ , servant-client >= 0.15+ , tasty+ , tasty-hunit+ , temporary+ , text+ , typed-process
+ src/Network/IPFS/Git/RemoteHelper.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Network.IPFS.Git.RemoteHelper+ ( ProcessError+ , renderProcessError++ , processCommand+ )+where++import Control.Concurrent.MVar (modifyMVar)+import Control.Exception.Safe+ ( MonadCatch+ , SomeException+ , catchAny+ , tryAny+ )+import Control.Monad.Except+import Control.Monad.Reader+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as L+import Data.Foldable (for_, toList, traverse_)+import Data.Functor ((<&>))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashSet as Set+import Data.IORef+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text (hPutStr, hPutStrLn)+import qualified Data.Text.Read as Text+import Data.Traversable (for)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import GHC.Stack (HasCallStack)+import System.FilePath (joinPath, splitDirectories)+import System.IO (hFlush, stderr)++import Data.Conduit+import qualified Data.Conduit.Combinators as Conduit++import Data.IPLD.CID (CID, cidFromText, cidToText)++import qualified Data.Git.Monad as Git (getGit, liftGit)+import Data.Git.Ref (SHA1)+import qualified Data.Git.Ref as Git (Ref)+import qualified Data.Git.Repository as Git (branchList, resolveRevision)+import qualified Data.Git.Revision as Git (Revision(..))+import qualified Data.Git.Storage as Git+ ( Git+ , findReference+ , getObject_+ , setObject+ )+import qualified Data.Git.Storage.Loose as Git (looseMarshall, looseUnmarshall)+import qualified Data.Git.Storage.Object as Git+ ( Object(ObjBlob)+ , ObjectLocation(..)+ , ObjectType(TypeBlob)+ , objectWrite+ , objectWriteHeader+ )++import Network.IPFS.Git.RemoteHelper.Client+import Network.IPFS.Git.RemoteHelper.Command+import Network.IPFS.Git.RemoteHelper.Format+import Network.IPFS.Git.RemoteHelper.Internal+import Network.IPFS.Git.RemoteHelper.Options (IpfsOptions'(..))+import Network.IPFS.Git.RemoteHelper.Trans+++data ProcessError+ = GitError SomeException+ | IPFSError ClientError+ | CidError String+ | UnknownLocalRef Text+ | HashError HashMismatch+ deriving Show++-- | Indicate two hashes expected to be equal aren't.+--+-- The data constructors take the expected value first, then the actual.+data HashMismatch+ = CidMismatch CID CID+ | RefMismatch (Git.Ref SHA1) (Git.Ref SHA1)+ deriving Show++instance DisplayError ProcessError where+ displayError = renderProcessError++renderProcessError :: ProcessError -> Text+renderProcessError = \case+ GitError e -> fmt ("Error accessing git repo: " % shown) e+ IPFSError e -> renderClientError e+ CidError e -> fmt ("Cid conversion error: " % fstr) e+ UnknownLocalRef r -> fmt ("Ref not found locally: " % ftxt) r+ HashError e -> renderHashMismatch e++renderHashMismatch :: HashMismatch -> Text+renderHashMismatch (CidMismatch e a) =+ fmt ("Cid mismatch: expected `" % fcid % "`, actual: `" % fcid % "`") e a+renderHashMismatch (RefMismatch e a) =+ fmt ("Ref mismatch: expected `" % fref % "`, actual: `" % fref % "`") e a++processCommand+ :: HasCallStack+ => Command+ -> RemoteHelper ProcessError CommandResult+processCommand Capabilities =+ pure $ CapabilitiesResult ["push", "fetch", "option"]++processCommand (Option name value) = fmap OptionResult $+ case name of+ "verbosity" -> case Text.decimal value of+ Left e -> pure $ OptionErr (fmt ("Invalid verbosity: " % fstr) e)+ Right (n,_) -> do+ ref <- asks envVerbosity+ liftIO . atomicModifyIORef' ref $ const (n, ())+ pure OptionOk++ "dry-run" -> do+ ref <- asks envDryRun+ let update v = liftIO . atomicModifyIORef' ref $ const (v,())+ case value of+ "true" -> OptionOk <$ update True+ "false" -> OptionOk <$ update False+ x -> pure $ OptionErr (fmt ("Invalid value for dry-run: " % ftxt) x)++ _ -> pure OptionUnsupported++processCommand List = fmap ListResult $ do+ root <- asks envIpfsRoot+ paths <- ipfs $ listPaths (cidToText root) 0++ let refpath = joinPath . drop 1 . dropWhile (== "/") . splitDirectories . refPathPath+ let name = Text.pack . refpath++ for paths $ \path ->+ case refPathType path of+ RefPathHead ->+ case hexShaFromCidText (refPathHash path) of+ Left e -> throwRH $ CidError e+ Right sha -> pure $ ListRef (Just sha) (name path) []++ RefPathRef -> do+ dest <- ipfs $ getRef (refpath path)+ pure $ ListRef (("@" <>) <$> dest) (name path) []++processCommand ListForPush = fmap ListForPushResult $ do+ root <- asks envIpfsRoot+ branches <-+ map (fmt $ "refs/heads/" % frefName) . toList <$> git Git.branchList+ logDebug $ fmt ("list for-push: branches: " % shown) branches++ remoteRefs <- do+ cids <-+ forConcurrently branches $ \branch ->+ ipfs (resolvePath (cidToText root <> "/" <> branch))++ for (catMaybes cids) $+ liftEitherRH . first CidError . hexShaFromCidText++ logDebug $ "list for-push: remoteRefs: " <> Text.pack (show remoteRefs)++ pure . map (\(ref, branch) -> ListRef (Just ref) branch [])+ . flip zip branches+ $ case remoteRefs of+ [] -> repeat "0000000000000000000000000000000000000000"+ xs -> xs++processCommand (Push force localRef remoteRef) =+ let+ err = PushResult . PushErr remoteRef+ ok = PushResult . PushOk remoteRef+ in+ fmap ok (processPush force localRef remoteRef)+ --`catchRH` (pure . err . renderProcessError)+ `catchAny` (pure . err . Text.pack . show)++processCommand (Fetch sha _) = FetchOk <$ processFetch sha++--------------------------------------------------------------------------------++processPush+ :: HasCallStack+ => Bool+ -> Text+ -> Text+ -> RemoteHelper ProcessError CID+processPush _ localRef remoteRef = do+ root <- asks envIpfsRoot++ localRefCid <- do+ ref <- git $ flip Git.resolveRevision (Git.Revision (Text.unpack localRef) [])+ maybe (throwRH $ UnknownLocalRef localRef) (pure . refToCid) ref++ remoteRefCid <- do+ refCid <- ipfs $ resolvePath (cidToText root <> "/" <> remoteRef)+ pure $ refCid >>= hush . cidFromText++ maxConc <- asks $ ipfsMaxConns . envIpfsOptions+ runConduit $+ yield localRefCid+ .| collectObjects remoteRefCid+ .| progress ("Pushed " % fint % " objects")+ .| Conduit.conduitVector maxConc+ .| Conduit.mapM_ (\(batch :: Vector (CID, Git.Object SHA1)) ->+ forConcurrently_ batch $ pushObject root)++ ipfs $ do+ -- Update the root to point to the local ref, up to which we just pushed+ root' <- patchLink root remoteRef localRefCid+ -- The remote HEAD denotes the default branch to check out. If it is not+ -- present, git clone will refuse to check out the worktree and exit+ -- with a scary error message.+ linkedObject "refs/heads/master" root' "HEAD" >>= \hEAD ->+ -- HEAD is our new root, update the remote.url and pin+ hEAD <$ concurrently_ (updateRemoteUrl hEAD) (pin hEAD)+ where+ collectObjects+ :: Maybe CID -- the CID already present remotely, if any+ -> ConduitT CID (CID, Git.Object SHA1) (RemoteHelper ProcessError) ()+ collectObjects remoteRefCid = do+ sref <- liftIO . newIORef $ maybe mempty Set.singleton remoteRefCid+ awaitForever $ \cid -> do+ seen <- liftIO $ readIORef sref+ unless (Set.member cid seen) $ do+ liftIO $ modifyIORef' sref (Set.insert cid)+ obj <- lift $ do+ sha <- liftEitherRH . first CidError $ cidToRef @SHA1 cid+ git $ \repo -> Git.getObject_ repo sha True++ yield (cid, obj)+ traverse_ leftover $ objectLinks obj++ pushObject root (cid, obj) = do+ let raw = Git.looseMarshall obj++ logDebug $ fmt ("Pushing " % fcid) cid+ blkCid <- ipfs $ putBlock raw+ when (cid /= blkCid) $+ throwRH $ HashError (CidMismatch cid blkCid)++ -- If the object exceeds the maximum block size, bitswap won't replicate+ -- the block. To work around this, we create a regular object and link+ -- it to the root object as @objects/<block CID>@.+ --+ -- As suggested by+ -- <https://github.com/ipfs-shipyard/git-remote-ipld/issues/12>, objects+ -- can potentially be deduplicated by storing the data separate from the+ -- header. This only makes sense for git blobs, so we don't bother for+ -- other object types.+ maxBlockSize <- asks $ fromIntegral . ipfsMaxBlockSize . envIpfsOptions+ when (L.length raw > maxBlockSize) $ do+ let linkName = "objects/" <> cidToText blkCid+ void . ipfs $+ case obj of+ Git.ObjBlob blob -> pushLargeBlob blob root linkName+ _ -> linkedObject raw root linkName++ pushLargeBlob blob root linkName =+ let+ hdr = L.fromStrict $ Git.objectWriteHeader Git.TypeBlob len+ len = fromIntegral $ L.length dat+ dat = Git.objectWrite (Git.ObjBlob blob)+ in do+ hdrCid <- addObject hdr+ datCid <- addObject dat+ patchLink hdrCid "0" datCid >>= patchLink root linkName++ linkedObject bytes root linkName =+ addObject bytes >>= patchLink root linkName++processFetch :: HasCallStack => Text -> RemoteHelper ProcessError ()+processFetch sha = do+ cid <- liftEitherRH . first CidError $ cidFromHexShaText sha+ lobs <- loadLobs+ maxC <- asks $ ipfsMaxConns . envIpfsOptions++ runConduit $+ yield (Vector.singleton cid)+ .| fetchObjects lobs maxC+ .| progress ("Fetched " % fint % " objects")+ .| Conduit.mapM_ storeObject++ void $ asks envIpfsRoot >>= ipfs . pin+ where+ fetchObjects+ :: HashMap CID CID -- LOB index+ -> Int -- Max concurrency+ -> ConduitT (Vector CID)+ (Git.Ref SHA1, Git.Object SHA1)+ (RemoteHelper ProcessError)+ ()+ fetchObjects !lobs maxConc = do+ sref <- liftIO $ newIORef Set.empty+ awaitForever $ \cids -> do+ seen <- liftIO $ readIORef sref+ todo <-+ fmap (Vector.mapMaybe id) . for cids $ \cid ->+ if Set.member cid seen then+ pure Nothing+ else do+ liftIO $ modifyIORef' sref (Set.insert cid)+ lift $ do+ ref <- liftEitherRH . first CidError $ cidToRef cid+ lookupObject ref <&> \case+ Git.NotFound -> Just (ref, cid)+ _ -> Nothing++ for_ (chunksOfV maxConc todo) $ \batch -> do+ objs <-+ lift . forConcurrently batch $ \(ref, cid) ->+ (ref,) <$> fetchObject lobs cid+ Conduit.yieldMany objs+ traverse_ leftover $ Vector.map (objectLinks . snd) objs++ fetchObject lobs cid = ipfs $ do+ lob <- provideLargeObject lobs cid+ Git.looseUnmarshall @SHA1 <$> maybe (getBlock cid) pure lob++ storeObject (ref, obj) = do+ ref' <- git $ flip Git.setObject obj+ when (ref' /= ref) $+ throwRH $ HashError (RefMismatch ref ref')++ lookupObject ref = git $ flip Git.findReference ref++ loadLobs = do+ env <- ask+ (>>= either throwError pure)+ . liftIO . modifyMVar (envLobs env) $ \case+ Just ls -> pure (Just ls, Right ls)+ Nothing ->+ runRemoteHelper env (ipfs (largeObjects (envIpfsRoot env))) >>= \case+ Left e -> pure (Nothing, Left e)+ Right ls -> pure (Just ls, Right ls)++--------------------------------------------------------------------------------++ipfs :: Monad m+ => RemoteHelperT ClientError m a+ -> RemoteHelperT ProcessError m a+ipfs = mapError IPFSError++-- XXX: hs-git uses 'error' deliberately, should be using 'tryAnyDeep' here.+-- Requires patch to upstream to get 'NFData' instances everywhere.+git :: (MonadCatch m, MonadIO m, HasCallStack)+ => (Git.Git SHA1 -> IO a)+ -> RemoteHelperT ProcessError m a+git f = do+ repo <- Git.getGit+ res <- Git.liftGit $ first GitError <$> tryAny (f repo)+ either throwRH pure res++chunksOfV :: Int -> Vector a -> Vector (Vector a)+chunksOfV n = Vector.unfoldr go+ where+ go v | Vector.null v = Nothing+ | otherwise = Just $ Vector.splitAt n v++progress :: MonadIO m => Format Text (Int -> Text) -> ConduitT a a m ()+progress msg = do+ let msg' = "\r" % msg % "\r"+ cref <- liftIO $ newIORef (0 :: Int)+ awaitForever $ \x -> do+ liftIO $ do+ count <- readIORef cref+ Text.hPutStr stderr (fmt msg' count) *> hFlush stderr+ modifyIORef' cref (+1)+ yield x+ liftIO $ Text.hPutStrLn stderr mempty *> hFlush stderr
+ src/Network/IPFS/Git/RemoteHelper/Client.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Network.IPFS.Git.RemoteHelper.Client+ ( RefPath (..)+ , RefPathType (..)++ , ClientError+ , renderClientError++ , listPaths+ , getRef+ , resolvePath+ , patchLink+ , putBlock+ , addObject+ , pin+ , largeObjects+ , provideLargeObject+ , getBlock+ , updateRemoteUrl+ )+where++import Control.Applicative (liftA2)+import Control.Exception.Safe+import qualified Control.Lens as Lens+import Control.Monad.Except+import Control.Monad.Reader+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Lens as Lens+import Data.Bifunctor (first)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as L (ByteString, fromChunks, null)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.Maybe (fromMaybe, maybeToList)+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT (decodeUtf8)+import Data.Traversable (for)+import System.FilePath (joinPath)+import System.Process.Typed (runProcess_, shell)++import Servant.API+import qualified Servant.Client as Servant+import qualified Servant.Client.Streaming as ServantS+import Servant.Types.SourceT++import Data.IPLD.CID (CID, cidFromText, cidToText)+import Network.IPFS.API++import Network.IPFS.Git.RemoteHelper.Format+import Network.IPFS.Git.RemoteHelper.Internal+import Network.IPFS.Git.RemoteHelper.Options+ ( IpfsPath(..)+ , optRemoteName+ , optRemoteUrl+ , remoteUrlIpfsPath+ , remoteUrlScheme+ )+import Network.IPFS.Git.RemoteHelper.Trans++#if MIN_VERSION_servant_client(0,16,0)+type ServantError = Servant.ClientError+#else+type ServantError = Servant.ServantError+#endif++data ClientError+ = ApiError ServantError+ | InvalidResponse Text Aeson.Value+ | CidError String+ | StreamingError String+ deriving Show++instance DisplayError ClientError where+ displayError = renderClientError++renderClientError :: ClientError -> Text+renderClientError = \case+ ApiError e -> fmt ("Error talking to IPFS: " % shown) e+ InvalidResponse msg raw -> fmt (ftxt % " -- " % shown) msg raw+ CidError msg -> fmt ("Cid conversion error: " % fstr) msg+ StreamingError msg -> fmt ("SourceT yielded error: " % fstr) msg++data RefPath = RefPath+ { refPathPath :: FilePath+ , refPathType :: RefPathType+ , refPathHash :: Text+ }++data RefPathType = RefPathRef | RefPathHead++listPaths+ :: MonadIO m+ => Text+ -> Word+ -> RemoteHelperT ClientError m [RefPath]+listPaths path !level = do+ logDebug $ "listPaths: " <> path+ refs <- ipfsList path Nothing (Just True)+ logDebug $ "listPaths: " <> Text.pack (show refs)+ fmap concat <$> for (Lens.toListOf linksL refs) $ \link ->+ case Lens.firstOf typeL link of+ Nothing -> throwRH $+ InvalidResponse "ipfsList: missing link type" refs+ -- directory:+ Just 1 ->+ case Lens.firstOf nameL link of+ Just "objects" | level == 0 -> pure []+ Just name -> listPaths (path <> "/" <> name) (level + 1)+ Nothing -> pure [] -- ??+ -- file:+ Just 2 -> pure . maybeToList $ do+ name <- Lens.firstOf nameL link+ hash <- Lens.firstOf hashL link+ pure RefPath+ { refPathPath = Text.unpack $ path <> "/" <> name+ , refPathType = RefPathRef+ , refPathHash = hash+ }+ -- unknown (assume head):+ --+ -- Nb.: unknown is 0 in ipfs version >= 0.4.19, and -1 in+ -- earlier versions.+ Just x | x == 0 || x == -1 -> pure . maybeToList $ do+ name <- Lens.firstOf nameL link+ hash <- Lens.firstOf hashL link+ pure RefPath+ { refPathPath = Text.unpack $ path <> "/" <> name+ , refPathType = RefPathHead+ , refPathHash = hash+ }+ -- Post-0.4.19, this can only be @TSymlink@, previously .. idk.+ -- Either way, we don't know what to do.+ Just x -> throwRH $+ InvalidResponse (fmt ("Unexpected link type: " % shown) x) refs++getRef+ :: (MonadCatch m, MonadIO m)+ => FilePath+ -> RemoteHelperT ClientError m (Maybe Text)+getRef name = do+ root <- asks $ Text.unpack . cidToText . envIpfsRoot++ let path = Text.pack $ joinPath [root, name]+ logDebug $ "getRef: " <> path+ bs <- stream (ipfsCat path Nothing Nothing) `catchRH` noLink+ if | L.null bs -> pure Nothing+ | otherwise -> pure . Just . LT.toStrict $ LT.decodeUtf8 bs+ where+ noLink (ApiError e) | isNoLink e = pure mempty+ noLink e = throwRH e++resolvePath :: MonadIO m => Text -> RemoteHelperT ClientError m (Maybe Text)+resolvePath p = do+ logDebug $ "Resolve path: " <> p+ res <- ipfsResolve p Nothing Nothing Nothing `catchRH` noLink+ pure . fmap strip $ Lens.firstOf pathL res+ where+ noLink (ApiError e) | isNoLink e = pure Aeson.Null+ noLink e = throwRH e++ strip x = fromMaybe x $ Text.stripPrefix "/ipfs/" x++patchLink :: MonadIO m => CID -> Text -> CID -> RemoteHelperT ClientError m CID+patchLink from name to = do+ logDebug $ fmt ("patchLink " % fcid % " " % ftxt % " " % fcid) from name to+ res <- ipfsObjectPatchAddLink (cidToText from) name (cidToText to) (Just True)+ either throwRH pure $ do+ hash <- note (invalidResponse res) $ Lens.firstOf hashL res+ first CidError $ cidFromText hash+ where+ invalidResponse =+ InvalidResponse "ipfsObjectPatchAddLink: expected 'Hash' key"++largeObjects :: MonadIO m => CID -> RemoteHelperT ClientError m (HashMap CID CID)+largeObjects root = do+ res <-+ ipfsList (cidToText root <> "/objects") Nothing Nothing `catchRH` noLink+ either throwRH (pure . Map.fromList)+ . for (Lens.toListOf linksL res) $ \link -> do+ hash <- toCid =<<+ note (invalidResponse "Hash" res) (Lens.firstOf hashL link)+ name <- toCid =<<+ note (invalidResponse "Link" res) (Lens.firstOf nameL link)+ pure (name, hash)+ where+ noLink (ApiError e) | isNoLink e = pure Aeson.Null+ noLink e = throwRH e++ invalidResponse =+ InvalidResponse . fmt ("ipfsList: expected '" % ftxt % "' key")++ toCid = first CidError . cidFromText++provideLargeObject+ :: (MonadCatch m, MonadIO m)+ => HashMap CID CID+ -> CID+ -> RemoteHelperT ClientError m (Maybe L.ByteString)+provideLargeObject largeObjs cid =+ for (Map.lookup cid largeObjs) $ \cid' ->+ stream $ ipfsCat ("/ipfs/" <> cidToText cid') Nothing Nothing++putBlock :: MonadIO m => L.ByteString -> RemoteHelperT ClientError m CID+putBlock bs = do+ res <- ipfsBlockPut bs (Just "git-raw") (Just "sha1") Nothing+ either throwRH pure $ do+ key <- note (invalidResponse res) $ Lens.firstOf keyL res+ first CidError $ cidFromText key+ where+ invalidResponse = InvalidResponse "ipfsBlockPut: expected 'Key' key"++addObject :: MonadIO m => L.ByteString -> RemoteHelperT ClientError m CID+addObject bs = do+ res <- ipfsAdd' bs+ liftEitherRH $ do+ sha <- note (invalidResponse res) $ Lens.firstOf hashL res+ first CidError $ cidFromText sha+ where+ invalidResponse = InvalidResponse "ipfsAdd: expected 'Hash' key"++ ipfsAdd' bs' =+ ipfsAdd bs' -- data+ Nothing -- recursive+ Nothing -- quiet+ Nothing -- quieter+ Nothing -- silent+ Nothing -- progress+ Nothing -- trickle+ Nothing -- only-hash+ Nothing -- wrap-with-directory+ Nothing -- hidden+ Nothing -- chunker+ (Just True) -- pin+ Nothing -- raw-leaves+ Nothing -- nocopy+ Nothing -- fscache+ Nothing -- cid-version+ Nothing -- hash function++pin :: MonadIO m => CID -> RemoteHelperT ClientError m [CID]+pin cid = do+ res <- ipfsPinAdd (cidToText cid)+ (Just True) -- recursive+ (Just False) -- progress+ liftEitherRH $+ traverse (first CidError . cidFromText) $ Lens.toListOf pinsL res++getBlock+ :: (MonadCatch m, MonadIO m)+ => CID+ -> RemoteHelperT ClientError m L.ByteString+getBlock cid = stream $ ipfsBlockGet (cidToText cid)++updateRemoteUrl :: MonadIO m => CID -> RemoteHelperT ClientError m ()+updateRemoteUrl root = do+ url <- asks $ optRemoteUrl . envOptions+ case remoteUrlIpfsPath url of+ IpfsPathIpns name -> viaIpns name+ IpfsPathIpfs _ -> viaConfig (remoteUrlScheme url) root+ where+ viaIpns name = do+ let ipnsTarget = "/ipfs/" <> cidToText root+ logInfo $+ fmt ("Updating IPNS link " % ftxt % " to " % ftxt) name ipnsTarget+ res <-+ ipfsNamePublish ipnsTarget+ (Just True) -- resolve+ (Just "2540400h") -- lifetime+ Nothing -- ttl (caching)+ (Just name) -- key++ case liftA2 (\name' root' -> name' == name && root' == ipnsTarget)+ (Lens.firstOf nameL res)+ (Lens.firstOf valueL res) of+ Just True -> pure ()+ _ -> throwRH $+ InvalidResponse+ (fmt ( "ipfsNamePublish: expected name "+ % "`" % ftxt % "` "+ % "pointing to `" % ftxt % "`"+ ) name ipnsTarget)+ res++ viaConfig scheme cid = do+ remoteName <- asks $ Text.pack . optRemoteName . envOptions+ let+ configKey = "remote." <> remoteName <> ".url"+ remoteUrl = scheme <> "://ipfs/" <> cidToText cid+ in do+ logInfo $+ fmt ("Updating " % ftxt % " to " % ftxt) configKey remoteUrl+ runProcess_ . shell . Text.unpack $+ "git config " <> configKey <> " " <> remoteUrl++-- lenses++linksL :: Lens.AsValue t => Lens.Traversal' t Aeson.Value+linksL = Lens.key "Objects" . Lens.nth 0 . Lens.key "Links" . Lens.values++typeL :: Lens.AsValue t => Lens.Traversal' t Int+typeL = Lens.key "Type" . Lens._Integral++nameL :: Lens.AsValue t => Lens.Traversal' t Text+nameL = Lens.key "Name" . Lens._String++messageL :: Lens.AsValue t => Lens.Traversal' t Text+messageL = Lens.key "Message" . Lens._String++hashL :: Lens.AsValue t => Lens.Traversal' t Text+hashL = Lens.key "Hash" . Lens._String++pathL :: Lens.AsValue t => Lens.Traversal' t Text+pathL = Lens.key "Path" . Lens._String++keyL :: Lens.AsValue t => Lens.Traversal' t Text+keyL = Lens.key "Key" . Lens._String++valueL :: Lens.AsValue t => Lens.Traversal' t Text+valueL = Lens.key "Value" . Lens._String++pinsL :: Lens.AsValue t => Lens.IndexedTraversal' Int t Text+pinsL = Lens.key "Pins" . Lens.values . Lens._String++-- brilliant API design+isNoLink :: ServantError -> Bool+isNoLink = \case+#if MIN_VERSION_servant_client(0,16,0)+ Servant.FailureResponse _ res ->+#else+ Servant.FailureResponse res ->+#endif+ case Lens.firstOf messageL (Servant.responseBody res) of+ Just m | "no link named" `Text.isPrefixOf` m -> True+ _ -> False+ _ -> False++-- | Subset of IPFS API needed for remote helper+type IPFS =+ ApiV0Add+ :<|> ApiV0BlockPut+ :<|> ApiV0Ls+ :<|> ApiV0ObjectPatchAddLink+ :<|> ApiV0Resolve+ :<|> ApiV0NamePublish+ :<|> ApiV0PinAdd++ipfsAdd+ :<|> ipfsBlockPut+ :<|> ipfsList+ :<|> ipfsObjectPatchAddLink+ :<|> ipfsResolve+ :<|> ipfsNamePublish+ :<|> ipfsPinAdd+ = client+ where+ client = Servant.hoistClient api nat (Servant.client api)++ nat m = do+ env <- asks envClient+ either (throwRH . ApiError) pure =<< liftIO (Servant.runClientM m env)++ api = Proxy @IPFS++-- | Streaming endpoints+type IPFS' = ApiV0BlockGet :<|> ApiV0Cat++ipfsBlockGet :<|> ipfsCat = ServantS.client (Proxy @IPFS')++stream+ :: (MonadCatch m, MonadIO m)+ => ServantS.ClientM (SourceT IO BS.ByteString)+ -> RemoteHelperT ClientError m L.ByteString+stream m = do+ env <- asks envClient+ liftIO (go env) `catches` handlers+ where+ handlers =+ [ Handler $ throwRH . ApiError+ , Handler $ \(StringException e _) -> throwRH $ StreamingError e+ ]++ go env =+ ServantS.withClientM m env $ \case+ Left e -> throwM e+ Right s -> runExceptT (runSourceT s) >>= \case+ Left e' -> throwString e'+ Right bss -> pure $ L.fromChunks bss+
+ src/Network/IPFS/Git/RemoteHelper/Command.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.IPFS.Git.RemoteHelper.Command+ ( Command (..)+ , CommandResult (..)+ , OptRes (..)+ , ListRef (..)+ , PushRes (..)++ , parseCommand+ , renderCommandResult+ )+where++import Control.Applicative (liftA2, optional, (<|>))+import Data.Attoparsec.ByteString.Char8 ((<?>))+import qualified Data.Attoparsec.ByteString.Char8 as P+import Data.Char (isSpace)+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)++import Data.IPLD.CID (CID)++data Command+ = Capabilities+ | List+ | ListForPush+ | Option Text Text -- name, value+ | Fetch Text Text -- sha1, name+ | Push Bool Text Text -- force, src ref, dest ref+ deriving Show++data CommandResult+ = CapabilitiesResult [Text]+ | ListResult [ListRef]+ | ListForPushResult [ListRef]+ | OptionResult OptRes+ | FetchOk+ | PushResult PushRes++data OptRes+ = OptionOk+ | OptionUnsupported+ | OptionErr Text++data ListRef = ListRef+ { listRefValue :: Maybe Text+ , listRefName :: Text+ , listRefAttrs :: [Text]+ }++data PushRes = PushOk Text CID | PushErr Text Text++parseCommand :: P.Parser Command+parseCommand =+ (capabilities <?> "capabilities")+ <|> (listForPush <?> "listForPush" )+ <|> (list <?> "list" )+ <|> (option <?> "option" )+ <|> (fetch <?> "fetch" )+ <|> (push <?> "push" )+ where+ capabilities = Capabilities <$ P.string "capabilities" <* eof+ list = List <$ P.string "list" <* eof+ listForPush = ListForPush <$ P.string "list for-push" <* eof++ option =+ P.string "option" *> P.skipSpace+ *> liftA2 Option (notSpace <* P.skipSpace) notSpace+ <* eof++ fetch =+ P.string "fetch" *> P.skipSpace+ *> liftA2 Fetch (notSpace <* P.skipSpace) notSpace+ <* eof++ push = do+ P.string "push" *> P.skipSpace+ force <- isJust <$> optional (P.char '+')+ src <- decodeUtf8 <$> P.takeWhile1 (/= ':') <* P.char ':'+ dst <- decodeUtf8 <$> P.takeByteString+ pure $ Push force src dst++ notSpace = decodeUtf8 <$> P.takeWhile1 (not . isSpace)+ eof = P.endOfInput++renderCommandResult :: CommandResult -> Text+renderCommandResult = \case+ CapabilitiesResult xs -> Text.unlines xs <> "\n"+ ListResult xs -> Text.unlines (map renderListRef xs) <> "\n"+ ListForPushResult xs -> Text.unlines (map renderListRef xs) <> "\n"+ OptionResult x -> renderOptRes x <> "\n"+ FetchOk -> "\n"+ PushResult x -> renderPushRes x <> "\n\n"++renderListRef :: ListRef -> Text+renderListRef ListRef{..} =+ fromMaybe "?" listRefValue+ <> " "+ <> listRefName+ <> Text.intercalate " " listRefAttrs++renderOptRes :: OptRes -> Text+renderOptRes OptionOk = "ok"+renderOptRes OptionUnsupported = "unsupported"+renderOptRes (OptionErr descr) = "error " <> descr++renderPushRes :: PushRes -> Text+renderPushRes (PushOk dst _ ) = "ok " <> dst+renderPushRes (PushErr ref descr) = "error " <> ref <> " " <> descr
+ src/Network/IPFS/Git/RemoteHelper/Format.hs view
@@ -0,0 +1,47 @@+module Network.IPFS.Git.RemoteHelper.Format+ ( fmt+ , sfmt+ , fstr+ , ftxt+ , fint+ , fcid+ , fref+ , frefName++ -- Re-exports+ , (%)+ , shown+ , Format+ )+where++import Data.Text (Text)+import Formatting++import qualified Data.Git.Named as Git (RefName, refNameRaw)+import qualified Data.Git.Ref as Git (Ref, toHexString)+import Data.IPLD.CID (CID, cidToText)++fmt :: Format Text a -> a+fmt = sformat++sfmt :: Format String a -> a+sfmt = formatToString++fstr :: Format r (String -> r)+fstr = string++ftxt :: Format r (Text -> r)+ftxt = stext++fint :: Integral a => Format r (a -> r)+fint = int++fcid :: Format r (CID -> r)+fcid = mapf cidToText stext++fref :: Format r (Git.Ref hash -> r)+fref = mapf Git.toHexString string++frefName :: Format r (Git.RefName -> r)+frefName = mapf Git.refNameRaw string
+ src/Network/IPFS/Git/RemoteHelper/Generic.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Network.IPFS.Git.RemoteHelper.Generic+ ( HKD+ , gvalidate+ , ginvalidate+ )+where++import Generics.SOP++-- The venerable defunctionalisation, applied generically, with a hipster touch+-- as popularised by Sandy "type fam" Maguire ("Higher Kinded Data", HKD)++-- | Eliminates the boring identity functor 'I'+type family HKD (f :: * -> *) (a :: *) :: * where+ HKD I a = a+ HKD f a = f a++-- | Generically lift the applicative functor 'f' out of a structure.+--+-- Example:+--+-- Given a datatype parametrised over the functor 'Maybe', return 'Just' the+-- value if all 'Maybe' fields are 'Just', thereby changing the functor to 'I'.+-- 'Nothing' otherwise.+--+-- >>> :{+-- >>> data Person f = Person { name :: f String, age :: f Int }+-- >>> deriving (Show, Generic, GHC.Generic)+-- >>> :}+-- >>> gvalidate $ Person (Just "LeBoeuf") (Just 42)+-- Just (Person (I "LeBoeuf") (I 42))+-- >>> gvalidate $ Person Nothing (Just 69)+-- Nothing+--+gvalidate+ :: ( Generic (a f)+ , Generic (a I)+ , Applicative f+ , AllZip2 (LiftedCoercible I f) (Code (a f)) (Code (a I))+ )+ => a f+ -> f (a I)+gvalidate = (to <$>) . hsequence . hcoerce . from++-- | Generically change the functor of a structure from 'I' to 'f', given a+-- constructor of 'f'.+--+-- Morally the inverse of 'gvalidate', although the specialisation to the+-- identity functor makes this trivial.+--+-- If 'a f' is a 'Semigroup', this can be used to apply defaults to a partial+-- value.+--+-- >>> :{+-- >>> instance Semigroup (Person Last) where+-- >>> a <> b = Person { name = on (<>) name a b, age = on (<>) age a b }+-- >>> -- For convenience, also define 'Monoid'+-- >>> instance Monoid (Person Last) were+-- >>> mempty = Person mempty mempty+-- >>> mappend = (<>)+-- >>> :}+-- >>> defaultPerson :: Person I+-- >>> defaultPerson = Person "Sandy" 28+-- >>> gvalidate $ ginvalidate pure defaultPerson <> Person (pure "Maguire") mempty+-- Just (Person (I "Maguire") (I 28)+--+ginvalidate+ :: ( Generic (a f)+ , Generic (a I)+ , AllZip2 (LiftedCoercible f I) (Code (a I)) (Code (a f))+ )+ => (forall b. b -> f b)+ -> a I+ -> a f+ginvalidate f = to . hcoerce . hmap (f . unI) . from
+ src/Network/IPFS/Git/RemoteHelper/Internal.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.IPFS.Git.RemoteHelper.Internal where++import qualified Crypto.Hash as C+import qualified Data.ByteString.BaseN as BaseN+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Vector (Vector)+import qualified Data.Vector as Vector++import qualified Data.Git.Ref as Git+import Data.Git.Storage.Object (Object(..))+import Data.Git.Types++import Data.IPLD.CID+ ( CID+ , Codec(..)+ , cidCodec+ , cidFromText+ , cidHash+ , newCidV1+ )+import Data.Multihash (Multihashable)+import qualified Data.Multihash as Multihash+++objectLinks :: Multihashable hash => Object hash -> Vector CID+objectLinks = \case+ ObjCommit x -> commitLinks x+ ObjTag x -> tagLinks x+ ObjBlob x -> blobLinks x+ ObjTree x -> treeLinks x+ -- XXX: not sure, possibly useful in the future+ ObjDeltaOfs _ -> mempty+ ObjDeltaRef _ -> mempty++treeLinks :: forall hash. Multihashable hash => Tree hash -> Vector CID+treeLinks (Tree entries) = foldMap (Vector.singleton . cid) entries+ where+ cid (_,_,ref) = refToCid @hash ref++commitLinks :: Multihashable hash => Commit hash -> Vector CID+commitLinks Commit { commitTreeish, commitParents } =+ Vector.singleton (refToCid commitTreeish)+ <> Vector.fromList (map refToCid commitParents)++tagLinks :: Multihashable hash => Tag hash -> Vector CID+tagLinks = Vector.singleton . refToCid . tagRef++blobLinks :: Blob hash -> Vector CID+blobLinks = const mempty++--------------------------------------------------------------------------------++cidFromHexShaText :: Text -> Either String CID+cidFromHexShaText t = do+ bytes <- BaseN.decodeBase16Either $ Text.encodeUtf8 t+ digest <- note ("Invalid digest: " <> Text.unpack t) $ C.digestFromByteString @Git.SHA1 bytes+ pure $ newCidV1 GitRaw digest++hexShaFromCidText :: Text -> Either String Text+hexShaFromCidText t = do+ cid <- cidFromText t+ Text.pack . Git.toHexString <$> cidToRef @Git.SHA1 cid++refToCid :: forall hash. Multihashable hash => Git.Ref hash -> CID+refToCid =+ newCidV1 GitRaw+ . fromMaybe (error "refToCid: Subverted Git.Ref supplied")+ . C.digestFromByteString @hash+ . Git.toBinary++cidToRef :: Multihashable hash => CID -> Either String (Git.Ref hash)+cidToRef cid =+ case cidCodec cid of+ GitRaw ->+ fmap Git.fromDigest+ . Multihash.decodeDigest+ . Multihash.encodedBytes+ $ cidHash cid+ codec -> Left $ "cidToRef: Unexpected codec `" <> show codec <> "`"++--------------------------------------------------------------------------------++note :: a -> Maybe b -> Either a b+note l = maybe (Left l) Right++hush :: Either a b -> Maybe b+hush = either (const Nothing) pure
+ src/Network/IPFS/Git/RemoteHelper/Options.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.IPFS.Git.RemoteHelper.Options where++import Control.Applicative (liftA2, (<|>))+import Control.Exception.Safe (throwString)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Function (on)+import Data.Git (withCurrentRepo)+import qualified Data.Git.Repository as Git+import Data.IPLD.CID (CID, cidFromText)+import Data.List (dropWhileEnd)+import Data.Monoid (Last(..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Generics.SOP as SOP+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)+import Network.URI+ ( parseURI+ , uriAuthority+ , uriPath+ , uriRegName+ , uriScheme+ )+import Options.Applicative+ ( Parser+ , ReadM+ , argument+ , eitherReader+ , metavar+ , strArgument+ )+import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)+import System.Environment (lookupEnv)+import Text.Read (readMaybe)++import Network.IPFS.Git.RemoteHelper.Generic+ ( HKD+ , ginvalidate+ , gvalidate+ )+import Network.IPFS.Git.RemoteHelper.Internal (note)+++data Options = Options+ { optRemoteName :: String+ , optRemoteUrl :: RemoteUrl+ }++data RemoteUrl = RemoteUrl+ { remoteUrlScheme :: Text+ , remoteUrlIpfsPath :: IpfsPath+ }++data IpfsPath+ = IpfsPathIpfs CID+ | IpfsPathIpns Text++type IpfsOptions = IpfsOptions' SOP.I++data IpfsOptions' f = IpfsOptions+ { ipfsApiUrl :: HKD f BaseUrl+ -- ^ URL of the IPFS daemon API.+ --+ -- Default: \"http://localhost:5001\"+ , ipfsMaxConns :: HKD f Int+ -- ^ Maximum number of concurrent connections to the IPFS daemon. Note that+ -- this is approximate.+ --+ -- Default: 30+ , ipfsMaxBlockSize :: HKD f Int+ -- ^ The maximum size of an IPFS block. This is configurable as there is no+ -- unambiguous documentation on what the actual value is. It may also be+ -- subject to change in the future.+ --+ -- Default: 2048000 (2MB)+ } deriving Generic++instance SOP.Generic (IpfsOptions' f)++instance Semigroup (IpfsOptions' Last) where+ a <> b = IpfsOptions+ { ipfsApiUrl = on (<>) ipfsApiUrl a b+ , ipfsMaxConns = on (<>) ipfsMaxConns a b+ , ipfsMaxBlockSize = on (<>) ipfsMaxBlockSize a b+ }++instance Monoid (IpfsOptions' Last) where+ mempty = IpfsOptions mempty mempty mempty+ mappend = (<>)++defaultIpfsOptions :: IpfsOptions+defaultIpfsOptions = IpfsOptions+ { ipfsApiUrl = BaseUrl Http "localhost" 5001 mempty+ , ipfsMaxConns = 30+ , ipfsMaxBlockSize = 2048000+ }++parseOptions :: Parser Options+parseOptions = liftA2 Options+ (strArgument (metavar "REMOTE_NAME"))+ (argument remoteUrl (metavar "URL"))++remoteUrl :: ReadM RemoteUrl+remoteUrl = eitherReader $ \s -> do+ uri <- note "Invalid URI" $ parseURI s+ let path = dropWhile (== '/') $ uriPath uri+ ipfs <-+ case uriRegName <$> uriAuthority uri of+ Just "ipns" -> pure . IpfsPathIpns . Text.pack $ path+ _ -> IpfsPathIpfs <$> cidFromString path+ pure RemoteUrl+ { remoteUrlScheme = Text.pack . dropWhileEnd (== ':') $ uriScheme uri+ , remoteUrlIpfsPath = ipfs+ }+ where+ cidFromString = cidFromText . \case+ [] -> emptyRepo+ xs -> Text.pack xs++ emptyRepo = "QmUNLLsPACCz1vLxQVkXqqLX5R1X345qqfHbsf67hvA3Nn"++-- | Determine the 'IpfsOptions'.+--+-- This must happen after 'parseOptions' in order to support per-remote+-- settings. The @GIT_DIR@ environment variable must be set and point to a valid+-- git repository (when the remote helper is invoked by git, this is the current+-- repository).+--+-- 'IpfsOptions' are configured using @git-config(2)@. The precedence rules+-- specified there apply. However, @$XDG_CONFIG_HOME/git/config@ and+-- @$(prefix)/etc/gitconfig@ (i.e. @--system@) are __not__ yet supported.+--+-- The available configuration keys are:+--+-- * @ipfs.apiurl@+-- * @ipfs.maxconnections@+-- * @ipfs.maxblocksize@+--+-- 'ipfsApiUrl' may be overridden per-remote using the key @remote.<remote+-- name>.ipfsapiurl@ (e.g. @remote.origin.ipfsapiurl@). If the environment+-- variable @IPFS_API_URL@, it will be used instead of any @git-config@+-- settings.+--+getIpfsOptions :: HasCallStack => Options -> IO IpfsOptions+getIpfsOptions Options { optRemoteName } = withCurrentRepo $ \r -> do+ ipfsApiUrl <-+ fmap Last . runMaybeT $ do+ url <-+ MaybeT (lookupEnv "IPFS_API_URL")+ <|> MaybeT (Git.configGet r ("remote \"" <> optRemoteName <> "\"") "ipfsapiurl")+ <|> MaybeT (Git.configGet r "ipfs" "apiurl")+ parseBaseUrl url++ ipfsMaxConns <-+ Last . (>>= readMaybe) <$> Git.configGet r "ipfs" "maxconnections"+ ipfsMaxBlockSize <-+ Last . (>>= readMaybe) <$> Git.configGet r "ipfs" "maxblocksize"++ maybe (throwString "Das Unmögliche ist eingetreten: Invalid IpfsOptions")+ pure+ . getLast+ . gvalidate+ $ ginvalidate pure defaultIpfsOptions <> IpfsOptions {..}
+ src/Network/IPFS/Git/RemoteHelper/Trans.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Network.IPFS.Git.RemoteHelper.Trans+ ( Logger (..)+ , defaultLogger++ , Env+ , newEnv+ , envVerbosity+ , envDryRun+ , envOptions+ , envIpfsOptions+ , envGit+ , envClient+ , envIpfsRoot+ , envLobs++ , RemoteHelper+ , RemoteHelperT+ , runRemoteHelper+ , runRemoteHelperT++ , DisplayError (..)++ , RemoteHelperError+ , errError+ , errCallStack+ , throwRH+ , catchRH+ , mapError+ , liftEitherRH++ , concurrently+ , concurrently_+ , forConcurrently_+ , forConcurrently++ , logInfo+ , logDebug+ , logError++ , renderSourceLoc+ )+where++import qualified Control.Concurrent.Async as Async+import Control.Concurrent.MVar (MVar, newMVar, withMVar)+import Control.Exception.Safe+import qualified Control.Lens as Lens+import Control.Monad.Except+import Control.Monad.Primitive+import Control.Monad.Reader+import qualified Data.Aeson.Lens as Lens+import Data.Bifunctor (first)+import Data.HashMap.Strict (HashMap)+import Data.IORef (IORef, newIORef, readIORef)+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Stack+ ( CallStack+ , HasCallStack+ , callStack+ , freezeCallStack+ , getCallStack+ , srcLocFile+ , srcLocStartLine+ )+import System.IO (stderr)++import Data.Git (Git)+import Data.Git.Monad (GitMonad(..))+import Data.Git.Ref (SHA1)+import Data.Git.Storage (findRepo, openRepo)++import Network.HTTP.Client+ ( defaultManagerSettings+ , managerResponseTimeout+ , newManager+ , responseTimeoutNone+ )+import Servant.Client.Streaming (mkClientEnv)+import qualified Servant.Client.Streaming as Servant++import Data.IPLD.CID (CID, cidFromText)+import Network.IPFS.API (ApiV0NameResolve)++import Network.IPFS.Git.RemoteHelper.Internal (note)+import Network.IPFS.Git.RemoteHelper.Options++data Logger = Logger+ { _logInfo :: Text -> IO ()+ , _logDebug :: Text -> IO ()+ , _logError :: Text -> IO ()+ }++data Env = Env+ { envVerbosity :: IORef Word+ , envDryRun :: IORef Bool+ , envOptions :: Options+ , envIpfsOptions :: IpfsOptions+ , envLogger :: Logger+ , envGit :: Git SHA1+ , envGitMutex :: MVar ()+ , envClient :: Servant.ClientEnv+ , envIpfsRoot :: CID+ , envLobs :: MVar (Maybe (HashMap CID CID))+ }++class DisplayError a where+ displayError :: a -> Text++data RemoteHelperError a = RemoteHelperError+ { errCallStack :: CallStack+ , errError :: a+ } deriving Show++instance+ (Show a, Typeable a, DisplayError a)+ => Exception (RemoteHelperError a)+ where+ displayException = Text.unpack . displayError++instance DisplayError a => DisplayError (RemoteHelperError a) where+ displayError e =+ displayError (errError e) <> " " <> renderSourceLoc (errCallStack e)++type RemoteHelper e = RemoteHelperT e IO++newtype RemoteHelperT e m a = RemoteHelperT+ { unRemoteHelperT :: ExceptT (RemoteHelperError e) (ReaderT Env m) a+ } deriving ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadReader Env+ , MonadError (RemoteHelperError e)+ , MonadThrow+ , MonadCatch+ , MonadMask+ )++instance MonadTrans (RemoteHelperT e) where+ lift = RemoteHelperT . lift . lift+ {-# INLINE lift #-}++instance PrimMonad m => PrimMonad (RemoteHelperT e m) where+ type PrimState (RemoteHelperT e m) = PrimState m+ primitive = lift . primitive+ {-# INLINE primitive #-}++instance MonadIO m => GitMonad (RemoteHelperT e m) where+ getGit = asks envGit+ liftGit f = do+ lck <- asks envGitMutex+ liftIO . withMVar lck . const $ f++ {-# INLINE getGit #-}+ {-# INLINE liftGit #-}++remoteHelperError :: CallStack -> a -> RemoteHelperError a+remoteHelperError cs e = RemoteHelperError+ { errCallStack = cs+ , errError = e+ }++throwRH :: (Monad m, HasCallStack) => e -> RemoteHelperT e m a+throwRH = throwError . remoteHelperError (freezeCallStack callStack)++catchRH+ :: Monad m+ => RemoteHelperT e m a+ -> (e -> RemoteHelperT e m a)+ -> RemoteHelperT e m a+catchRH ma f = catchError ma (f . errError)++mapError+ :: Monad m+ => (e -> e')+ -> RemoteHelperT e m a+ -> RemoteHelperT e' m a+mapError f (RemoteHelperT ma) =+ RemoteHelperT $ flip withExceptT ma $ \e ->+ e { errError = f (errError e) }++liftEitherRH :: (Monad m, HasCallStack) => Either e a -> RemoteHelperT e m a+liftEitherRH =+ liftEither . first (remoteHelperError (freezeCallStack callStack))++concurrently+ :: (Show e, Typeable e, DisplayError e)+ => RemoteHelperT e IO a+ -> RemoteHelperT e IO b+ -> RemoteHelperT e IO (a, b)+concurrently left right = do+ env <- ask+ liftIO $ Async.concurrently+ (either throwM pure =<< runRemoteHelperT env left)+ (either throwM pure =<< runRemoteHelperT env right)++concurrently_+ :: (Show e, Typeable e, DisplayError e)+ => RemoteHelperT e IO a+ -> RemoteHelperT e IO b+ -> RemoteHelperT e IO ()+concurrently_ left right = do+ env <- ask+ liftIO $ Async.concurrently_+ (either throwM pure =<< runRemoteHelperT env left)+ (either throwM pure =<< runRemoteHelperT env right)++forConcurrently_+ :: ( Foldable t+ , Show e+ , Typeable e+ , DisplayError e+ )+ => t a+ -> (a -> RemoteHelperT e IO b)+ -> RemoteHelperT e IO ()+forConcurrently_ xs f = do+ env <- ask+ liftIO $+ Async.forConcurrently_ xs $ \x ->+ either throwM pure =<< runRemoteHelperT env (f x)++forConcurrently+ :: ( Traversable t+ , Show e+ , Typeable e+ , DisplayError e+ )+ => t a+ -> (a -> RemoteHelperT e IO b)+ -> RemoteHelperT e IO (t b)+forConcurrently xs f = do+ env <- ask+ liftIO $+ Async.forConcurrently xs $ \x ->+ either throwM pure =<< runRemoteHelperT env (f x)++logInfo :: MonadIO m => Text -> RemoteHelperT e m ()+logInfo msg = do+ out <- asks $ _logInfo . envLogger+ v <- liftIO . readIORef =<< asks envVerbosity+ when (v > 0) $+ liftIO $ out msg++logDebug :: (HasCallStack, MonadIO m) => Text -> RemoteHelperT e m ()+logDebug msg = do+ out <- asks $ _logDebug . envLogger+ v <- liftIO . readIORef =<< asks envVerbosity+ when (v > 1) $+ liftIO . out $ msg <> renderSourceLoc callStack++logError :: (HasCallStack, MonadIO m) => Text -> RemoteHelperT e m ()+logError msg = do+ out <- asks $ _logError . envLogger+ liftIO . out $ msg <> renderSourceLoc callStack++renderSourceLoc :: CallStack -> Text+renderSourceLoc cs =+ case getCallStack cs of+ ((_, loc) : _) ->+ " (" <> Text.pack (srcLocFile loc)+ <> ":"+ <> Text.pack (show (srcLocStartLine loc))+ <> ")"+ _ ->+ " (<unknown>)"++defaultLogger :: Logger+defaultLogger = Logger out out out+ where+ out = Text.hPutStrLn stderr++newEnv :: HasCallStack => Logger -> Options -> IpfsOptions -> IO Env+newEnv envLogger envOptions envIpfsOptions = do+ envVerbosity <- newIORef 1+ envDryRun <- newIORef False+ envGit <- findRepo >>= openRepo+ envGitMutex <- newMVar ()+ envLobs <- newMVar Nothing+ envClient <-+ flip mkClientEnv (ipfsApiUrl envIpfsOptions)+ <$> newManager defaultManagerSettings+ { managerResponseTimeout = responseTimeoutNone }+ envIpfsRoot <-+ case remoteUrlIpfsPath (optRemoteUrl envOptions) of+ IpfsPathIpfs cid -> pure cid+ IpfsPathIpns name -> do+ _logInfo envLogger $ "Resolving IPNS name " <> name+ res <-+ flip Servant.runClientM envClient $+ ipfsNameResolve name+ (Just True) -- recursive+ Nothing+ Nothing+ Nothing+ case res of+ Left e -> throwM e+ Right v -> either throwString pure $ do+ path <-+ note "ipfsNameResolve: expected 'Path' key" $+ Lens.firstOf (Lens.key "Path" . Lens._String) v+ cidFromText+ . fromMaybe path+ $ Text.stripPrefix "/ipfs/" path++ pure Env {..}+ where+ ipfsNameResolve = Servant.client (Proxy @ApiV0NameResolve)++runRemoteHelperT+ :: Env+ -> RemoteHelperT e m a+ -> m (Either (RemoteHelperError e) a)+runRemoteHelperT r = flip runReaderT r . runExceptT . unRemoteHelperT++runRemoteHelper :: Env -> RemoteHelper e a -> IO (Either (RemoteHelperError e) a)+runRemoteHelper = runRemoteHelperT
+ test/e2e/Main.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Main where++import Control.Applicative (liftA2)+import Control.Exception.Safe (throwM, throwString)+import Control.Lens (firstOf)+import Control.Monad (void)+import Data.Aeson.Lens (key, _String)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as Bytes+import Data.ByteString.Lazy (fromStrict, toStrict)+import qualified Data.ByteString.Lazy.Char8 as Lazy+import Data.Foldable (foldlM)+import qualified Data.Git.Monad as Git+import Data.Git.Ref (SHA1)+import qualified Data.Git.Storage as Git (initRepo)+import Data.Git.Types (GitTime(..))+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy(..))+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)+import GHC.Stack (HasCallStack)+import qualified Network.HTTP.Client as Http+import Network.IPFS.API (ApiV0KeyGen, ApiV0NamePublish)+import Servant.API+import qualified Servant.Client as Servant+import System.Entropy (getEntropy)+import System.Environment (lookupEnv)+import System.Exit (ExitCode(..))+import System.FilePath (takeBaseName, takeDirectory, (</>))+import System.Hourglass (timeCurrent, timezoneCurrent)+import System.IO.Temp (withSystemTempDirectory)+import System.Process.Typed++import Test.Tasty+import Test.Tasty.HUnit++type Step = String -> IO ()++main :: IO ()+main =+ withSystemTempDirectory "git-remote-ipfs-e2e" $ \tmp -> defaultMain $+ testGroup "E2E Tests"+ [ testCaseSteps "Push, clone: IPFS" $ testPushCloneSimple tmp+ , testCaseSteps "Push, clone: IPNS" $ testPushCloneIPNS tmp+ , testCaseSteps "Push, clone: LOB IPFS" $ testLargeObjects tmp+ ]++testPushCloneSimple :: FilePath -> Step -> IO ()+testPushCloneSimple root step = runPushCloneTest PushCloneOpts+ { pcoRepo = root </> "simple" </> ".git"+ , pcoClone = root </> "simple-clone" </> ".git"+ , pcoRemoteUrl = "ipfs://"+ , pcoHistory = simpleHistory+ , pcoLog = step+ }++testPushCloneIPNS :: FilePath -> Step -> IO ()+testPushCloneIPNS root step = do+ let keyName = Text.pack (takeBaseName root) -- piggypack on randomness of tmp+ step "Creating IPNS name"+ ipnsName <- Text.unpack <$> ipfs (createIpnsName keyName)+ runPushCloneTest PushCloneOpts+ { pcoRepo = root </> ipnsName </> ".git"+ , pcoClone = root </> ipnsName ++ "-clone" </> ".git"+ , pcoRemoteUrl = "ipfs://ipns/" <> ipnsName+ , pcoHistory = simpleHistory+ , pcoLog = step+ }+ where+ ipfs m = servantEnv >>= Servant.runClientM m >>= either throwM pure++testLargeObjects :: FilePath -> Step -> IO ()+testLargeObjects root step = runPushCloneTest PushCloneOpts+ { pcoRepo = root </> "lobs" </> ".git"+ , pcoClone = root </> "lobs-clone" </> ".git"+ , pcoRemoteUrl = "ipfs://"+ , pcoHistory = lobHistory+ , pcoLog = step+ }++data PushCloneOpts = PushCloneOpts+ { pcoRepo :: FilePath+ , pcoClone :: FilePath+ , pcoRemoteUrl :: String+ , pcoHistory :: FilePath -> IO ()+ , pcoLog :: Step+ }++runPushCloneTest :: PushCloneOpts -> IO ()+runPushCloneTest PushCloneOpts{..} = do+ initRepo pcoLog pcoRepo pcoHistory++ url <- pushIpfs pcoLog pcoRepo pcoRemoteUrl+ cloneIpfs pcoLog (takeDirectory pcoClone) url++ assertSameRepos pcoLog pcoRepo pcoClone++initRepo :: HasCallStack => Step -> FilePath -> (FilePath -> IO ()) -> IO ()+initRepo step repo history = do+ step $ "Initializing repo at " <> repo+ let repo' = fromString repo+ Git.initRepo repo'+ (>>= either throwString pure) . Git.withRepo repo' $+ Git.headSet $ pure "master"+ history repo++pushIpfs :: Step -> FilePath -> String -> IO String+pushIpfs step repo url = do+ step $ "Pushing master to " <> url+ git_ repo ["remote", "add", "origin", url]+ git_ repo ["push", "--quiet", "origin", "master"]+ Text.unpack . Text.strip . decodeUtf8+ <$> git repo ["remote", "get-url", "origin"]++cloneIpfs :: Step -> FilePath -> String -> IO ()+cloneIpfs step repo url = do+ step $ "Cloning " <> url <> " to " <> repo+ git_ repo ["clone", "--quiet", url, repo]++assertSameRepos :: Step -> FilePath -> FilePath -> IO ()+assertSameRepos step src clone = do+ step $ "Fetching " <> src <> " to " <> clone+ git_ clone ["remote", "add", "src", src]+ git_ clone ["fetch", "--quiet", "src"]+ step "Comparing origin/master src/master"+ void $ gitAssert "Source and cloned repository differ"+ clone ["diff", "--quiet", "origin/master", "src/master"]++simpleHistory :: FilePath -> IO ()+simpleHistory repo =+ (>>= either throwString (const $ pure ())) . Git.withRepo (fromString repo) $ do+ initial <- mkCommit Nothing Nothing 0+ foldlM (\(bs, rev) i -> mkCommit bs rev i) initial [1..42]+ where+ mkCommit+ :: Maybe Lazy.ByteString+ -> Maybe String+ -> Int+ -> Git.GitM (Maybe Lazy.ByteString, Maybe String)+ mkCommit readme branch (show -> i) = do+ person <- mkPerson <$> currentTimeGit+ (r, ()) <-+ Git.withNewCommit person branch $ do+ Git.setMessage $ "Commit " <> Bytes.pack i+ Git.setFile ["README"] $+ fromMaybe mempty readme <> Lazy.pack i <> "\n"+ Git.branchWrite "master" r+ (,Just "master") <$>+ Git.withCommit ("master" :: String) (Git.getFile ["README"])++lobHistory :: FilePath -> IO ()+lobHistory repo = do+ blob <- getEntropy 4096000+ (>>= either throwString pure) . Git.withRepo (fromString repo) $ do+ person <- mkPerson <$> currentTimeGit+ (r, ()) <-+ Git.withNewCommit person (Nothing :: Maybe (Git.Ref SHA1)) $ do+ Git.setMessage "Huuuuge"+ Git.setFile ["huge.file"] $ fromStrict blob+ Git.branchWrite "master" r++mkPerson :: GitTime -> Git.Person+mkPerson = Git.Person "LeBoeuf" "le@boe.uf"++currentTimeGit :: Git.GitM GitTime+currentTimeGit = Git.liftGit $ liftA2 GitTime timeCurrent timezoneCurrent++git :: FilePath -> [String] -> IO ByteString+git = gitAssert mempty++git_ :: FilePath -> [String] -> IO ()+git_ repo args = void $ git repo args++gitAssert :: String -> FilePath -> [String] -> IO ByteString+gitAssert msg repo args = do+ let cfg = proc "git" $ "--git-dir" : repo : args+ readProcess cfg >>= \case+ (ExitSuccess, out, _err) -> pure $ toStrict out+ (failure , out, err ) -> assertFailure $ unlines+ [ msg+ , show failure+ , show cfg+ , show out+ , show err+ ]++type IPFS = ApiV0KeyGen :<|> ApiV0NamePublish++ipfsKeyGen :<|> ipfsNamePublish = Servant.client (Proxy @IPFS)++servantEnv :: IO Servant.ClientEnv+servantEnv = liftA2 Servant.mkClientEnv mgr base+ where+ mgr = Http.newManager Http.defaultManagerSettings+ { Http.managerResponseTimeout = Http.responseTimeoutNone }++ base =+ Servant.parseBaseUrl+ =<< fromMaybe "http://localhost:5001" <$> lookupEnv "IPFS_API_URL"++createIpnsName :: HasCallStack => Text -> Servant.ClientM Text+createIpnsName keyName = do+ keyId <-+ maybe (throwString "Missing key Id") pure+ . firstOf (key "Id" . _String)+ =<< ipfsKeyGen keyName (Just "ed25519") Nothing+ void $+ ipfsNamePublish ("/ipfs/" <> emptyRepo)+ (Just True) -- resolve+ (Just "5m") -- lifetime+ Nothing -- caching+ (Just keyId) -- key+ pure keyId+ where+ emptyRepo = "QmUNLLsPACCz1vLxQVkXqqLX5R1X345qqfHbsf67hvA3Nn"