fr33domlover <fr33domlover@riseup.net>

Creative Commons Legal Code

CC0 1.0 Universal

    CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE

    LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN

    ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS

    INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES

    REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS

    PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM

    THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED

    HEREUNDER.

Statement of Purpose

The laws of most jurisdictions throughout the world automatically confer

exclusive Copyright and Related Rights (defined below) upon the creator

and subsequent owner(s) (each and all, an "owner") of an original work of

authorship and/or a database (each, a "Work").

Certain owners wish to permanently relinquish those rights to a Work for

the purpose of contributing to a commons of creative, cultural and

scientific works ("Commons") that the public can reliably and without fear

of later claims of infringement build upon, modify, incorporate in other

works, reuse and redistribute as freely as possible in any form whatsoever

and for any purposes, including without limitation commercial purposes.

These owners may contribute to the Commons to promote the ideal of a free

culture and the further production of creative, cultural and scientific

works, or to gain reputation or greater distribution for their Work in

part through the use and efforts of others.

For these and/or other purposes and motivations, and without any

expectation of additional consideration or compensation, the person

associating CC0 with a Work (the "Affirmer"), to the extent that he or she

is an owner of Copyright and Related Rights in the Work, voluntarily

elects to apply CC0 to the Work and publicly distribute the Work under its

terms, with knowledge of his or her Copyright and Related Rights in the

Work and the meaning and intended legal effect of CC0 on those rights.

1. Copyright and Related Rights. A Work made available under CC0 may be

protected by copyright and related or neighboring rights ("Copyright and

Related Rights"). Copyright and Related Rights include, but are not

limited to, the following:

  i. the right to reproduce, adapt, distribute, perform, display,

     communicate, and translate a Work;

 ii. moral rights retained by the original author(s) and/or performer(s);

iii. publicity and privacy rights pertaining to a person's image or

     likeness depicted in a Work;

 iv. rights protecting against unfair competition in regards to a Work,

     subject to the limitations in paragraph 4(a), below;

  v. rights protecting the extraction, dissemination, use and reuse of data

     in a Work;

 vi. database rights (such as those arising under Directive 96/9/EC of the

     European Parliament and of the Council of 11 March 1996 on the legal

     protection of databases, and under any national implementation

     thereof, including any amended or successor version of such

     directive); and

vii. other similar, equivalent or corresponding rights throughout the

     world based on applicable law or treaty, and any national

     implementations thereof.

2. Waiver. To the greatest extent permitted by, but not in contravention

of, applicable law, Affirmer hereby overtly, fully, permanently,

irrevocably and unconditionally waives, abandons, and surrenders all of

Affirmer's Copyright and Related Rights and associated claims and causes

of action, whether now known or unknown (including existing as well as

future claims and causes of action), in the Work (i) in all territories

worldwide, (ii) for the maximum duration provided by applicable law or

treaty (including future time extensions), (iii) in any current or future

medium and for any number of copies, and (iv) for any purpose whatsoever,

including without limitation commercial, advertising or promotional

purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each

member of the public at large and to the detriment of Affirmer's heirs and

successors, fully intending that such Waiver shall not be subject to

revocation, rescission, cancellation, termination, or any other legal or

equitable action to disrupt the quiet enjoyment of the Work by the public

as contemplated by Affirmer's express Statement of Purpose.

3. Public License Fallback. Should any part of the Waiver for any reason

be judged legally invalid or ineffective under applicable law, then the

Waiver shall be preserved to the maximum extent permitted taking into

account Affirmer's express Statement of Purpose. In addition, to the

extent the Waiver is so judged Affirmer hereby grants to each affected

person a royalty-free, non transferable, non sublicensable, non exclusive,

irrevocable and unconditional license to exercise Affirmer's Copyright and

Related Rights in the Work (i) in all territories worldwide, (ii) for the

maximum duration provided by applicable law or treaty (including future

time extensions), (iii) in any current or future medium and for any number

of copies, and (iv) for any purpose whatsoever, including without

limitation commercial, advertising or promotional purposes (the

"License"). The License shall be deemed effective as of the date CC0 was

applied by Affirmer to the Work. Should any part of the License for any

reason be judged legally invalid or ineffective under applicable law, such

partial invalidity or ineffectiveness shall not invalidate the remainder

of the License, and in such case Affirmer hereby affirms that he or she

will not (i) exercise any of his or her remaining Copyright and Related

Rights in the Work or (ii) assert any associated claims and causes of

action with respect to the Work, in either case contrary to Affirmer's

express Statement of Purpose.

4. Limitations and Disclaimers.

 a. No trademark or patent rights held by Affirmer are waived, abandoned,

    surrendered, licensed or otherwise affected by this document.

 b. Affirmer offers the Work as-is and makes no representations or

    warranties of any kind concerning the Work, express, implied,

    statutory or otherwise, including without limitation warranties of

    title, merchantability, fitness for a particular purpose, non

    infringement, or the absence of latent or other defects, accuracy, or

    the present or absence of errors, whether or not discoverable, all to

    the greatest extent permissible under applicable law.

 c. Affirmer disclaims responsibility for clearing rights of other persons

    that may apply to the Work or any use thereof, including without

    limitation any person's Copyright and Related Rights in the Work.

    Further, Affirmer disclaims responsibility for obtaining any necessary

    consents, permissions or other rights required for any use of the

    Work.

 d. Affirmer understands and acknowledges that Creative Commons is not a

    party to this document and has no duty or obligation with respect to

    this CC0 or use of the Work.

The changes are recorded by the version control system, Darcs. To see a log

quickly from the terminal, run:

  $ darcs changes --repo http://hub.darcs.net/fr33domlover/hit-harder

There is also a web interface at <http://hub.darcs.net> which, among other

things, can display the history log.

To see the log in a local clone, first get a copy of the repository if you

haven't yet:

  $ darcs get http://hub.darcs.net/fr33domlover/hit-harder

Then move into the newly created directory and run darcs:

  $ cd hit-harder

  $ darcs changes

Install from Hackage/Stackage:

    $ stack install hit-harder

Install from unpacked release tarball or source repo:

    $ cd hit-harder

    $ stack install

Just play with it without installing:

    $ stack repl

This file lists the user-visible interesting changes between releases. For a

full list of changes to the source, see the ChangeLog.

hit-harder 0.1        unreleased

================================

General, build and documentation changes:

* (This is the first release, so everything is new)

New APIs, features and enhancements:

* (This is the first release, so everything is a new feature)

Bug fixes:

* (This is just the first release, many bugs haven't been discovered yet)

Dependency changes:

* (This is the first release)

See the .cabal file for more info and link to project website the version

control.

The official download location is Hackage:

<http://hackage.haskell.org/package/hit-harder>

This library is free software, and is committed to software freedom. It is

released to the public domain using the CC0 Public Domain Dedication. For the

boring "legal" details see the file 'COPYING'.

See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains

how to see the history log of the changes done in the code. 'NEWS' provides a

friendly overview of the changes for each release.

import Distribution.Simple

main = defaultMain

# This file contains a list of extended regular expressions, one per

# line. A file path matching any of these expressions will be filtered

# out during `darcs add', or when the `--look-for-adds' flag is passed

# to `darcs whatsnew' and `record'.  The entries in ~/.darcs/boring (if

# it exists) supplement those in this file.

# 

# Blank lines, and lines beginning with an octothorpe (#) are ignored.

# See regex(7) for a description of extended regular expressions.

### compiler and interpreter intermediate files

# haskell (ghc) interfaces

\.hi$

\.hi-boot$

\.o-boot$

# object files

\.o$

\.o\.cmd$

# profiling haskell

\.p_hi$

\.p_o$

# haskell program coverage resp. profiling info

\.tix$

\.prof$

# fortran module files

\.mod$

# linux kernel

\.ko\.cmd$

\.mod\.c$

(^|/)\.tmp_versions($|/)

# *.ko files aren't boring by default because they might

# be Korean translations rather than kernel modules

# \.ko$

# python, emacs, java byte code

\.py[co]$

\.elc$

\.class$

# objects and libraries; lo and la are libtool things

\.(obj|a|exe|so|lo|la)$

# compiled zsh configuration files

\.zwc$

# Common LISP output files for CLISP and CMUCL

\.(fas|fasl|sparcf|x86f)$

### build and packaging systems

# cabal intermediates

\.installed-pkg-config

\.setup-config

# standard cabal and stack build dirs

^dist$

^dist/build(/|$)

^dist/doc(/|$)

^dist/dist-sandbox

^dist/package\.conf\.inplace$

^dist/setup-config$

^\.cabal-sandbox(/|$)

^cabal\.sandbox\.config$

^.stack-work(/|$)

# autotools

(^|/)autom4te\.cache($|/)

(^|/)config\.(log|status)$

# gentoo tools

\.revdep-rebuild.*

# generated dependencies

^\.depend$

### version control systems

# cvs

(^|/)CVS($|/)

\.cvsignore$

# cvs, emacs locks

^\.#

# rcs

(^|/)RCS($|/)

,v$

# subversion

(^|/)\.svn($|/)

# mercurial

(^|/)\.hg($|/)

# git

(^|/)\.git($|/)

# bzr

\.bzr$

# sccs

(^|/)SCCS($|/)

# darcs

(^|/)_darcs($|/)

(^|/)\.darcsrepo($|/)

^\.darcs-temp-mail$

-darcs-backup[[:digit:]]+$

# gnu arch

(^|/)(\+|,)

(^|/)vssver\.scc$

\.swp$

(^|/)MT($|/)

(^|/)\{arch\}($|/)

(^|/).arch-ids($|/)

### miscellaneous

# backup files

~$

\.bak$

\.BAK$

# patch originals and rejects

\.orig$

\.rej$

# X server

\..serverauth.*

# vi, emacs tags

(^|/)(tags|TAGS)$

#(^|/)\.[^/]

# core dumps

(^|/|\.)core$

# partial broken files (KIO copy operations)

\.part$

# waf files, see http://code.google.com/p/waf/

(^|/)\.waf-[[:digit:].]+-[[:digit:]]+($|/)

(^|/)\.lock-wscript$

name:                hit-harder

version:             0.1

synopsis:            More Git tools in pure Haskell on top of 'hit'

description:

  During my work on a Haskell implementation of the Git pack protocol, which is

  still in progress at the time of writing, I've been writing various general

  purpose utilities. At the beginning I just dumped them into Util modules, but

  at some point the collection of utils felt too useful to be kept like that,

  and I decided to create a separate package for them.

homepage:            http://hub.darcs.net/fr33domlover/hit-harder

bug-reports:         mailto:fr33domlover@riseup.net

license:             PublicDomain

license-file:        COPYING

author:              fr33domlover

maintainer:          fr33domlover@riseup.net

copyright:           ♡ Copying is an act of love. Please copy, reuse and share.

category:            Git, Development

build-type:          Simple

extra-source-files:  AUTHORS ChangeLog COPYING INSTALL.md NEWS.md README.md

cabal-version:       >=1.10

source-repository head

  type:                darcs

  location:            http://hub.darcs.net/fr33domlover/hit-harder

library

  exposed-modules:     Data.Git.Harder

  -- other-modules:       

  -- other-extensions:    

  build-depends:       base                 >= 4.8 && < 5

                     --, containers

                     --, fgl

                     --, hashable

                     , hit

                     --, transformers

                     --, unordered-containers

  hs-source-dirs:      src

  default-language:    Haskell2010

  ghc-options:         -Wall

{- This file is part of hit-harder.

 -

 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.

 -

 - ♡ Copying is an act of love. Please copy, reuse and share.

 -

 - The author(s) have dedicated all copyright and related and neighboring

 - rights to this software to the public domain worldwide. This software is

 - distributed without any warranty.

 -

 - You should have received a copy of the CC0 Public Domain Dedication along

 - with this software. If not, see

 - <http://creativecommons.org/publicdomain/zero/1.0/>.

 -}

module Data.Git.Harder

    ( -- * Refs

      ObjId (..)

    , resolveNameMaybe

    , resolveName

    , listReferences

      -- * Commits

    , loadCommits

    , loadCommitsMulti

      -- * Trees

    , getEntryObject

    , getEntryObject_

    , TraversalAction (..)

    , traverseTree

    , viewTree

    , resolveTreePath

    )

where

--import Control.Monad.IO.Class

import Data.Foldable (find, foldl', foldlM)

import Data.Git.Named (RefName (..))

import Data.Git.Ref (Ref, toBinary)

import Data.Git.Repository

import Data.Git.Revision (Revision (..))

import Data.Git.Storage (Git, getObject, getObject_, getObjectType)

import Data.Git.Storage.Object (Object (..))

import Data.Git.Types

--import Data.Hashable (Hashable (..))

import Data.Maybe (catMaybes, fromMaybe)

--import Data.Ord (Down (..))

import Data.Traversable (for)

--import qualified Data.DList as D

--import qualified Data.HashMap.Strict as M

--import qualified Data.Set as S

--import Data.Graph.Inductive.Query.Topsort

-- | A git object identifier. This is a SHA-1 hash. Its common textual

-- representation is a 40-byte ASCII hexadecimal string.

newtype ObjId = ObjId { unObjId :: Ref } deriving Eq

instance Hashable ObjId where

    hashWithSalt salt = hashWithSalt salt . toBinary . unObjId

    hash = hash . toBinary . unObjId

-- | For a given ref name - HEAD or branch or tag - determine its ref hash.

resolveNameMaybe :: Git -> String -> IO (Maybe ObjId)

resolveNameMaybe git name =

    fmap ObjId <$> resolveRevision git (Revision name [])

-- | For a given ref name - HEAD or branch or tag - determine its ref hash.

resolveName :: Git -> String -> IO ObjId

resolveName git name = do

    moid <- resolveNameMaybe git name

    return $ fromMaybe (error "No such ref name in the repo") moid

-- | List the available references in a git repo, sorted by ref name. The list

-- includes HEAD, branches and tags.

listReferences :: Git -> IO [(ObjId, String)]

listReferences git = do

    branches <- S.mapMonotonic refNameRaw <$> branchList git

    tags <- S.mapMonotonic refNameRaw <$> tagList git

    let names = S.toAscList $ S.insert "HEAD" $ S.union branches tags

    mentries <-

        traverse

            (\ name -> fmap (flip (,) name) <$> resolveNameMaybe git name)

            names

    return $ catMaybes mentries

-- | Load the entire graph of commits which are ancestors of the given ref

-- (and that ref itself). Fold the commit structure into a value of type @a@

-- inside monad @m@.

--

-- This is a low-level function which operates on a commit tree, i.e. the same

-- ref may be visited more than once (if it has more than one child commit).

-- You can use the provided flexibility to implement graph algorithms over the

-- commits, or build a graph using some graph library and use that library's

-- tools for further processing.

loadCommits

    :: MonadIO m

    => Git

    -- ^ Open git repository context

    -> ((ObjId, Commit) -> ObjId -> a -> m (a, Maybe Commit))

    -- ^ Given a child commit, one of its parent commits and an @a@ value,

    -- generate an updated @a@ value. The second returned value determines

    -- whether traversal should proceed to the parent of the parent commit. If

    -- you return 'Nothing', it won't. If you load the parent commit (e.g. with

    -- 'getCommit') and return 'Just' it, traversal will proceed to its

    -- parents.

    -> a

    -- ^ Initial value

    -> ObjId

    -- ^ Hash of the commit whose ancestor graph should be loaded

    -> Maybe Commit

    -- ^ If you already read the commit for the ref passed as the previous

    -- parameter, pass the commit here to avoid repeated loading of it.

    -- Otherwise, pass 'Nothing' and it will be read from the repo.

    -> m a

loadCommits git func val oid mcmt = readCommitMaybe oid mcmt >>= go val oid

    where

    readCommit = liftIO . getCommit git . unObjId

    readCommitMaybe r = maybe (readCommit r) return

    step p v r = do

        (v', mc) <- func p r v

        case mc of

            Nothing -> return v'

            Just c  -> go v' r c

    go v r c = foldlM (step (r, c)) v $ map ObjId $ commitParents c

-- | Like 'loadCommits', but takes a list of refs and goes over all their

-- ancestors. This is just a convenience shortcut which folds a list with

-- 'loadCommits'. Passing a list with a single element is the same as running

-- 'loadCommits'.

loadCommitsMulti

    :: MonadIO m

    => Git

    -- ^ Open git repository context

    -> ((ObjId, Commit) -> ObjId -> a -> m (a, Maybe Commit))

    -- ^ Given a child commit, one of its parent commits and an @a@ value,

    -- generate an updated @a@ value. The second returned value determines

    -- whether traversal should proceed to the parent of the parent commit. If

    -- you return 'Nothing', it won't. If you load the parent commit (e.g. with

    -- 'getCommit') and return 'Just' it, traversal will proceed to its

    -- parents.

    -> a

    -- ^ Initial value

    -> [(ObjId, Maybe Commit)]

    -- ^ Commits whose ancestors to scan. For each commit, pass:

    --

    -- (1) Hash of the commit

    -- (2) If you already loaded the commit from the ref, pass the commit here

    --     to avoid repeated loading of it. Otherwise, pass 'Nothing' and it

    --     will be read from the repo.

    -> m a

loadCommitsMulti git func val pairs =

    foldlM (\ v (r, mc) -> loadCommits git func v r mc) val pairs

-- | TODO

getEntryObject :: Git -> ObjId -> IO (Maybe (Either Blob Tree))

getEntryObject git oid = do

    mobj <- getObject git (unObjId oid) True

    case mobj of

        Nothing  -> return Nothing

        Just obj ->

            case obj of

                ObjBlob b -> return $ Just $ Left b

                ObjTree t -> return $ Just $ Right t

                _         -> error "expected blob or tree"

-- | TODO

getEntryObject_ :: Git -> ObjId -> IO (Either Blob Tree)

getEntryObject_ git oid = do

    obj <- getObject_ git (unObjId oid) True

    case obj of

        ObjBlob b -> return $ Left b

        ObjTree t -> return $ Right t

        _         -> error "expected blob or tree"

-- | TODO

data TraversalAction = TAStop | TAContinue | TAContinueWith Tree

-- | Aside of dependency on previous commits (i.e. parents), each commit object

-- refers to a tree object, and the tree refers to more trees and to blobs. For

-- a given tree root, this function goes over these trees and blobs, and runs

-- the given action on each.

--

-- TODOOOO update the doc comments of this function and its args

traverseTree

    :: MonadIO m

    => Git

    -- ^ Open git repository

    -> (a -> ObjId -> ModePerm -> EntName -> m (a, TraversalAction))

    -- ^ This action will be executed for each tree entry found. The first

    -- parameter is the value being accumulated. The next three parameters are

    -- the tree entry details (object ID, permissions and filename). The last

    -- parameter is 'True' if that entry is a tree, and 'False' if it's a blob.

    -- What's returned is an updated value and whether to descend to the tree's

    -- entries (for a blob, this value is ignored).

    -> Tree

    -- ^ Tree root whose entries will be traversed recursively.

    -> a

    -- ^ Initial value

    -> m a

traverseTree git action root initial = foldlM go' initial $ treeGetEnts root

    where

    go' v (p, n, r) = go v (ObjId r) p n

    go value oid perm name = do

        (value', next) <- action value oid perm name

        let descend = foldlM go' value' . treeGetEnts

        case next of

            TAStop -> return value'

            TAContinue -> do

                object <- liftIO $ getEntryObject_ git oid

                case object of

                    Left _     -> return value'

                    Right tree -> descend tree

            TAContinueWith tree -> descend tree

-- | A simple utility for listing info of a tree's content. The last tuple

-- element is 'True' for a tree and 'False' for a blob.

viewTree :: Git -> Tree -> IO [(ModePerm, EntName, Bool)]

viewTree git tree = for (treeGetEnts tree) $ \ (perm, name, ref) -> do

    mtype <- getObjectType git ref

    case mtype of

        Nothing       -> error "tree contains an invalid entry ref"

        Just TypeTree -> return (perm, name, True)

        Just TypeBlob -> return (perm, name, False)

        Just _        -> error "unexpected tree entry object type"

-- | Given a tree, resolve the given path in it and return the 'ObjId' found

-- (which should be either a Tree or a Blob, i.e. a directory or a file). If

-- the path doesn't exist, throw exception. If the path is the empty list, it

-- refers to the tree you passed, and 'Nothing' is returned.

resolveTreePath :: Git -> Tree -> EntPath -> IO (Maybe ObjId)

resolveTreePath _    _   []     = return Nothing

resolveTreePath git tree (p:ps) =

    let match ent (_, name, _) = name == ent

        go ref []     = return $ Just $ ObjId ref

        go ref (q:qs) = do

            t <- getTree git ref

            case find (match q) $ treeGetEnts t of

                Nothing        -> error "no such path in tree"

                Just (_, _, r) -> go r qs

    in  case find (match p) $ treeGetEnts tree of

            Nothing          -> error "no such path in the tree"

            Just (_, _, ref) -> go ref ps

{- This file is part of hit-harder.

 -

 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.

 -

 - ♡ Copying is an act of love. Please copy, reuse and share.

 -

 - The author(s) have dedicated all copyright and related and neighboring

 - rights to this software to the public domain worldwide. This software is

 - distributed without any warranty.

 -

 - You should have received a copy of the CC0 Public Domain Dedication along

 - with this software. If not, see

 - <http://creativecommons.org/publicdomain/zero/1.0/>.

 -}

module Data.Git.Harder.Pack

    (

    )

where

import Data.Binary.Put

import Data.Bits

putPackHeader :: Int -> Put

putPackHeader numOfObjects = do

    putByteString "PACK"    -- Signature

    putWord32be 2           -- Version number

    putInt32be numOfObjects -- Number of objects contained in the pack

type ObjIdSet = HashSet ObjId

-- | Take a minimal list of commits we must send, and build a set of object IDs

-- of these commits and all the trees and blobs they refer to recursively.

collectObjIds :: Git -> [(ObjId, Commit)] -> IO ObjIdSet

collectObjIds git pairs = do

    let (commitIds, commits) = unzip pairs

        treeIds = map (commitTreeish git) commits

        resolve tid = do

            mtree <- resolveTreeish git $ unObjId tid

            return $ fromMaybe (error "invalid commit treeish ref") mtree

        visit s oid _ _ _ = S.insert oid s

        collect = traverseTree git visit

    trees <- traverse resolve treeIds

    let initial = S.fromList commitsIds `S.union` S.fromList treeIds

    foldlM (flip collect) initial trees

data CompressedObject = CompressedObject

    { zoType :: ObjectType

    , zoSize :: Word64

    , zoData :: BL.ByteString

    }

objectTypeCode :: Num a => ObjectType -> a

objectTypeCode TypeCommit   = 1

objectTypeCode TypeTree     = 2

objectTypeCode TypeBlob     = 3

objectTypeCode TypeTag      = 4

objectTypeCode TypeDeltaOff = 6

objectTypeCode TypeDeltaRef = 7

-- | Get the low 7 bits of a number. You get them as the low 7 bits of the

-- 'Word8' returned.

low7bits :: Bits a => a -> Word8

low7bits n =

    let mw = fromIntegralSized $ n .&. 0x7f

        msg = "toIntegralSized failed to convert small Bits a (0-127) to Word8"

    in  fromMaybe (error msg) mw

-- | This is an encoder for a specific encoding of arbitrary-length numbers

-- used by Git. The purpose is to support objects of arbitrary size, not

-- limiting their size representation to 32 or 64 bits.

--

-- The encoding work as follows. The number is split into sequences of 7 bits,

-- in little endian order (i.e. least significant bits come first). For each

-- sequence, a byte is constructed. The sequence serve as the low 7 bits of it,

-- and the highest bit determines whether there is another sequence after it.

-- In other words, the last byte has that bit set to 0, and all other bytes

-- have it set to 1.

--

-- The encoding contains at least one byte. If the word value is 127 or less,

-- i.e. can be expressed in 7 bits, the encoding contains a single byte.

-- Otherwise, it's more than one byte, as needed.

putExtensibleWord :: Bits a => a -> Put

putExtensibleWord n =

    let first = low7bits n

        rest = unsafeShiftR n 7

    in  putExtensibleWord' first rest

-- | Like 'putExtensibleWord'', but lets you manually pass the first 7 bits

-- separately from the rest of the bits.

--

-- If the rest of the bits are all zeros, te encoding will contain a single

-- byte (the first 7 bits passed, and a zero high bit). Otherwise, it will

-- contain at least 2 bytes: 1 byte for the first 7 bits, and at least 1 byte

-- for the rest of the bits.

putExtensibleWord'

    :: Bits a

    => Word8  -- ^ The low 7 bits of the word

    -> a      -- ^ The rest of the bits

    -> Put

putExtensibleWord' first rest =

    let setHigh = (.|. 0x80)

        clearHigh = (.&. 0x7f)

        continues = setHigh

        stops = clearHigh

    if rest == zeroBits

        then putWord8 $ stops first

        else do

            putWord8 $ continues first

            let first' = low7bits rest

                rest' = unsafeShiftR rest 7

            putExtensibleWord' first' rest'

putObjectHeader :: ObjectType -> Word64 -> Put

putObjectHeader otype size =

    let typeBits = objectTypeCode otype

        msizeLowBits = toIntegralSized $ size .&. 0x0f

        sizeLowBits = case msizeLowBits of

            Nothing ->

                error

                    "toIntegralSized failed to convert small (0-15) Word64 to \

                    \Word8 in putObjectHeader"

            Just n  -> n

        first7bits = unsafeShiftL typeBits 4 .|. sizeLowBits

    in  putExtensibleWord' first7bits (unsafeShiftR size 4)

putCompressedObject :: CompressedObject -> Put

putCompressedObject zo = do

    putObjectHeader (zoType zo) (zoSize zo)

    putLazyByteString $ zoData zo

compressObject :: ObjectInfo -> CompressedObject

compressObect (ObjectInfo (t, s, _mp) odata _ochains) = CompressedObject

    { zoType = t

    , zoSize = s

    , zoData = compress odata

    }

putObject :: ObjectInfo -> Put

putObject = putCompressedObject . compressObject

mkPutObject :: Git -> ObjId -> IO Put

mkPutObject git oid = do

    minfo <- getObjectRaw git (unObjId oid) True

    case minfo of

        Nothing   -> error "failed to load raw object from oid"

        Just info -> return $ putObject info

writeHashed :: Put -> HashT SHA1 IO Put

writeHashed put = do

    let lbs = runPut put

    updateHashMulti $ toChunks lbs

    return $ putLazyByteString lbs

writePack :: Git -> ObjIdSet -> IO Put

writePack git oidset = do

    (put, digest) <- runHashT $ do

        header <- writeHashed $ putPackHeader $ S.size oidset

        let writeObj oid = liftIO (mkPutObject git oid) >>= writeHashed

        foldlM (\ put oid -> (put >>) <$> writeObj oid) header oidset

    return $ put >> putByteString (convert digest)

# For more information, see:

# http://docs.haskellstack.org/en/stable/yaml_configuration.html

# Specifies the GHC version and set of packages available (e.g., lts-3.5,

# nightly-2015-09-21, ghc-7.10.2)

resolver: lts-5.14

# Local packages, usually specified by relative directory name

packages:

  - '.'

# Packages to be pulled from upstream that are not in the resolver (e.g.,

# acme-missiles-0.3)

extra-deps: []

# Override default flag values for local packages and extra-deps

flags: {}

# Extra package databases containing global packages

extra-package-dbs: []

# Control whether we use the GHC we find on the path

# system-ghc: true

# Require a specific version of stack, using version ranges

# require-stack-version: -any # Default

# require-stack-version: >= 1.0.0

# Override the architecture used by stack

# arch: i386

# arch: x86_64

# Extra directories used by stack for building

# extra-include-dirs: [/path/to/dir]

# extra-lib-dirs: [/path/to/dir]

# Allow a newer minor version of GHC than the snapshot specifies

# compiler-check: newer-minor