miss-porcelain (empty) → 0
raw patch · 6 files changed
+257/−0 lines, 6 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, filesystem-abstractions, list-tries, miss, mtl, posix-paths
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- miss-porcelain.cabal +36/−0
- src/Data/Git/EditTree.hs +108/−0
- src/Data/Git/FileTree.hs +76/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for miss-porcelain++## 0 -- 2018-12-28++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, davean++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 davean nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ miss-porcelain.cabal view
@@ -0,0 +1,36 @@+cabal-version: 2.2++name: miss-porcelain+version: 0+synopsis: Useability extras built on top of miss.+description:+ This package builds on 'miss', providing convinient interfaces for working with git repositories.+homepage: https://oss.xkcd.com/+bug-reports: https://code.xkrd.net/skete/miss-porcelain/issues+license: BSD-3-Clause+license-file: LICENSE+author: Alec Heller & davean+maintainer: oss@xkcd.com+copyright: Copyright (C) 2015-2018 Alec Heller & davean+category: Git, Development+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://code.xkrd.net/skete/miss-porcelain.git++library+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Data.Git.EditTree+ Data.Git.FileTree+ build-depends:+ base >=4.9.0.0 && < 4.13+ , bytestring ^>= 0.10+ , containers ^>= 0.6 + , filesystem-abstractions ^>= 0+ , list-tries ^>= 0.6+ , miss ^>= 0+ , mtl ^>= 2.2+ , posix-paths ^>= 0.2
+ src/Data/Git/EditTree.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-|++Description: A monad for manipulating trees of files from git.++An 'EditTree' is a convenient representation of a 'Tree'. The leaves of an 'EditTree' are either+the contents of a 'Blob', a sub-'EditTree', or a 'Sha1'. This makes it easier to work with large+'Tree's, because subobjects are stored as hashes until you modify them.++-}++module Data.Git.EditTree where++import Prelude hiding (fail)+import Control.Monad.Fail+import Control.Monad.State hiding (fail)+import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL+import Data.Git+import Data.Map (Map)+import qualified Data.Map as Map+import System.Posix.FilePath+++-- | A nice representation of a 'Tree'.+type EditTree = Map TreeEntry TreePart++-- | The leaves of an 'EditTree'---either a hash, 'Blob' data, or a subtree.+data TreePart = PartSha Sha1 | PartData ByteString | PartTree EditTree++-- | A monad for editing 'EditTree's.+newtype TreeEdit m a = TreeEdit { runTreeEdit :: StateT EditTree m a }+ deriving (Functor, Applicative, Monad, MonadState EditTree, MonadIO, MonadTrans, MonadFail)++-- | Turn the given treeish 'Sha1' into an 'EditTree' whose leaves are all hashes.+loadEditTree :: (MonadGit m, MonadFail m) => Sha1 -> m EditTree+loadEditTree r = do (Just (Tree ents)) <- findTreeish r+ return $ fmap PartSha ents++-- | Traverse an 'EditTree', writing new objects, and return the 'Sha1' of the new 'Tree'.+writeEditTree :: MonadGit m => EditTree -> m Sha1+writeEditTree = writeTree . Tree <=< traverse partToSha+ where partToSha (PartSha s) = return s+ partToSha (PartData b) = writeBlob $ Blob b+ partToSha (PartTree t) = writeEditTree t++-- | Run a 'TreeEdit' computation against an 'EditTree', *without* writing the new objects out.+don'tEditTree :: MonadGit m => EditTree -> TreeEdit m a -> m EditTree+don'tEditTree et te = execStateT (runTreeEdit te) et++-- | Run a 'TreeEdit' computation against an 'EditTree', writing new objects as they occur.+editTree :: MonadGit m => EditTree -> TreeEdit m a -> m EditTree+editTree et te = do et' <- don'tEditTree et te+ _ <- writeEditTree et'+ return et'++-- | Delete an entry from the 'EditTree'.+rm :: Monad m => TreeEntry -> TreeEdit m ()+rm = modify . Map.delete++-- | Run a 'TreeEdit' in the subtree at the given path.+cd :: (MonadFail m, MonadGit m) => RawFilePath -> TreeEdit m a -> TreeEdit m a+cd dir act = splitPathComponents dir >>= (`cd'` act)++-- | As 'cd', but with a list of path components.+cd' :: (MonadFail m, MonadGit m) => [PathComponent] -> TreeEdit m a -> TreeEdit m a+cd' [] te = te+cd' (d:ds) te = cd1 d (cd' ds te)++-- | A one-level version of 'cd'.+cd1 :: (MonadFail m, MonadGit m) => PathComponent -> TreeEdit m a -> TreeEdit m a+cd1 d te = do old <- get+ let dir = Entry d TreeMode+ case old Map.! dir of+ PartTree et -> put et+ PartSha r -> put =<< lift (loadEditTree r)+ _ -> error "cd1 exploded"+ ret <- te+ modify (\et -> Map.insert dir (PartTree et) old)+ return ret++-- | Place a new leaf with the given filename.+create :: Monad m => TreeEntry -> TreePart -> TreeEdit m ()+create name ent = modify (Map.insert name ent)++-- | Create a subtree with the given filename.+mkdir :: MonadFail m => PathComponent -> TreeEdit m ()+mkdir dir = modify (Map.insertWith (flip const) (Entry dir TreeMode) (PartTree mempty))++-- | Create a path into the tree and do some 'TreeEdit's in that location.+cdCreating :: (MonadFail m, MonadGit m) => RawFilePath -> TreeEdit m a -> TreeEdit m a+cdCreating path te = (`cdCreating'` te) =<< splitPathComponents path++-- | As 'cdCreating', but with a list of path components.+cdCreating' :: (MonadFail m, MonadGit m) => [PathComponent] -> TreeEdit m a -> TreeEdit m a+cdCreating' path te = go path+ where go [] = te+ go (d:ds) = mkdir d >> cd1 d (go ds)++-- | A shortcut to create a bunch of files at once.+createFiles :: Monad m => Map PathComponent B.ByteString -> TreeEdit m ()+createFiles m = sequence_ [create (Entry file BlobMode) $ PartData (BL.fromStrict blob)+ | (file, blob) <- Map.toList m]
+ src/Data/Git/FileTree.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++{-|++Description: A convenient way to work with directory trees.++-}++module Data.Git.FileTree+ (+ module System.Filesystem.FileTree+ , FileData+ , buildFileTree+ , loadFileTree+ ) where++import Control.Monad+import Control.Monad.Fail+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable+import Data.Git.Formats+import Data.Git.Hash+import Data.Git.Monad+import Data.Git.Object+import Data.Git.Types+import qualified Data.ListTrie.Map.Ord as LT+import qualified Data.Map as Map+import System.Filesystem.FileTree++-- | The contents of a file and its executability.+type FileData = (BSL.ByteString, Bool)++-- | Write the contents of a 'FileTree' out to git and give back the new 'Tree's 'Sha1'.+buildFileTree :: MonadGit m => FileTree FileData -> m Sha1+buildFileTree fls | LT.null fls = writeTree mempty+ | otherwise = writeTree =<< ((Tree . Map.fromList) <$> (go . LT.children1 $ fls))+ where+ go :: MonadGit m => Map.Map PathComponent (FileTree FileData) -> m [(TreeEntry, Sha1)]+ go m = forM (Map.toList m) $ \(k, t) -> do+ case LT.toList t of+ [([], (fd, ex))] -> -- we're at a leaf+ (Entry k (if ex then ExecMode else BlobMode),)+ <$> (writeBlob . Blob $ fd)+ _ -> (Entry k TreeMode,) <$> buildFileTree t++-- | Turn the 'Sha1' of a treeish into a 'FileTree'.+loadFileTree :: (MonadFail m, MonadGit m) => Sha1 -> m (FileTree FileData)+loadFileTree r = do t <- findTreeish r+ maybe (return LT.empty) (fmap fold . mapM go . Map.toList . getTree) t+ where+ getFiletypeHack :: Mode -> Maybe Bool+ getFiletypeHack BlobMode = Just True+ getFiletypeHack ExecMode = Just True+ getFiletypeHack TreeMode = Just False+ getFiletypeHack _ = Nothing+ go (Entry name perm, ref) = case getFiletypeHack perm of+ Just True -> do+ Just (Blob b) <- findBlob ref+ return $ LT.singleton [name] (b, perm == ExecMode)+ Just False -> do+ dt <- loadFileTree ref+ return $ LT.addPrefix [name] dt+ Nothing -> error $ "don't know how to load " ++ show perm++-- for debugging purposes only+{-+showTreeWith :: Show a => (FileData -> a) -> FileTree FileData -> String+showTreeWith f t = LT.showTrie (fmap f t) ""++showTree :: FileTree FileData -> String+showTree = showTreeWith go+ where+ go (fd, exec) =+ Prelude.concat ["(", show . BSL.length $ fd, " bytes", if exec then ", *" else "", ")"]+-}