Created
June 16, 2017 23:56
-
-
Save dashea/52e6155e87825b1171005abe27cbb417 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE LambdaCase #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
import Control.Conditional(whenM) | |
import Control.Exception(bracket_) | |
import Control.Monad(forM_, void) | |
import Control.Monad.State(StateT, execStateT, lift, modify) | |
import Data.GI.Base.ManagedPtr(unsafeCastTo) | |
import Data.Text(Text) | |
import GI.Gio | |
import GI.OSTree | |
import System.FilePath((</>)) | |
import System.IO.Temp(withTempDirectory) | |
import System.Posix.Files(createSymbolicLink) | |
initRepo :: FilePath -> IO (Repo, [Text]) | |
initRepo repoDir = do | |
path <- fileNewForPath repoDir | |
repo <- repoNew path | |
repoCreate repo RepoModeArchiveZ2 noCancellable | |
commit <- addContent repo | |
checksums <- execStateT (commitContents repo commit) [] | |
return (repo, checksums) | |
where | |
addContent :: IsRepo a => a -> IO Text | |
addContent repo = withTransaction repo $ \r -> do | |
-- create a temp directory with some content to import | |
f <- withTempDirectory "." "ostree-test-content" $ \contentDir -> do | |
cdPath <- fileNewForPath contentDir | |
createSymbolicLink "/dev/null" (contentDir </> "test-link") | |
mtree <- mutableTreeNew | |
repoWriteDirectoryToMtree r cdPath mtree Nothing noCancellable | |
repoWriteMtree r mtree noCancellable | |
-- commit the tree as "master" | |
unsafeCastTo RepoFile f >>= \root -> do | |
checksum <- repoWriteCommit r Nothing (Just "Test commit") Nothing Nothing root noCancellable | |
repoTransactionSetRef r Nothing "master" (Just checksum) | |
repoRegenerateSummary r Nothing noCancellable | |
return checksum | |
withTransaction :: IsRepo a => a -> (a -> IO b) -> IO b | |
withTransaction repo fn = | |
bracket_ (repoPrepareTransaction repo noCancellable) | |
(repoCommitTransaction repo noCancellable) | |
(fn repo) | |
commitContents :: IsRepo a => a -> Text -> StateT [Text] IO () | |
commitContents repo commit = do | |
(root, _) <- repoReadCommit repo commit noCancellable | |
file <- fileResolveRelativePath root "/" | |
info <- fileQueryInfo file "*" [FileQueryInfoFlagsNofollowSymlinks] noCancellable | |
walk file info | |
where | |
walk :: File -> FileInfo -> StateT [Text] IO () | |
walk f i = lift (fileInfoGetFileType i) >>= \case | |
FileTypeDirectory -> do getChecksum FileTypeDirectory f >>= addChecksum | |
-- Grab the info for everything in this directory. | |
dirEnum <- fileEnumerateChildren f "*" [FileQueryInfoFlagsNofollowSymlinks] noCancellable | |
childrenInfo <- getAllChildren dirEnum [] | |
-- Examine the contents of this directory recursively - this results in all | |
-- the files being added by the other branch of the case, and other directories | |
-- being handled recusrively. Thus, we do this depth-first. | |
forM_ childrenInfo $ \childInfo -> do | |
child <- fileInfoGetName childInfo >>= fileGetChild f | |
walk child childInfo | |
ty -> getChecksum ty f >>= addChecksum | |
addChecksum :: Text -> StateT [Text] IO () | |
addChecksum c = modify (c:) | |
getAllChildren :: FileEnumerator -> [FileInfo] -> StateT [Text] IO [FileInfo] | |
getAllChildren enum accum = | |
fileEnumeratorNextFile enum noCancellable >>= \case | |
Just next -> getAllChildren enum (accum ++ [next]) | |
Nothing -> return accum | |
getChecksum :: FileType -> File -> StateT [Text] IO Text | |
getChecksum ty f = lift $ unsafeCastTo RepoFile f >>= \repoFile -> | |
case ty of | |
FileTypeDirectory -> do -- this needs to be called before repoFileTreeGetMetadataChecksum to populate the data | |
repoFileEnsureResolved repoFile | |
repoFileTreeGetMetadataChecksum repoFile | |
_ -> repoFileGetChecksum repoFile | |
main :: IO () | |
main = void $ withTempDirectory "." "ostree-test-" $ \tmpDir -> do | |
-- create the repo and add some content | |
-- (all of this seems to work fine) | |
(repo, checksums) <- initRepo tmpDir | |
mapM_ (getObject repo) checksums | |
where | |
getObject :: IsRepo a => a -> Text -> IO () | |
getObject repo checksum = do | |
print $ "Loading " ++ show checksum | |
whenM (repoHasObject repo ObjectTypeFile checksum noCancellable) loadFile | |
where | |
loadFile :: IO () | |
-- This is where the problems happen | |
loadFile = void $ repoLoadFile repo checksum noCancellable |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment