From c4026d5b94b2a31ff9465aa90a7b49a503b81747 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vojt=C4=9Bch=20K=C3=A1n=C4=9B?= Date: Thu, 23 Sep 2021 12:54:42 +0200 Subject: [PATCH] Initial commit --- flake.lock | 27 +++++++ flake.nix | 17 ++++ main.hs | 231 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 275 insertions(+) create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 main.hs diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..1887429 --- /dev/null +++ b/flake.lock @@ -0,0 +1,27 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1630651144, + "narHash": "sha256-Q9vSzbYbN74WS8RN6wndylCefZTYETW06frPDBcrTZM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "698335e05af68a49e629e417520a967f60c854cc", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "master", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..c51e9c8 --- /dev/null +++ b/flake.nix @@ -0,0 +1,17 @@ +{ + inputs.nixpkgs.url = "github:NixOS/nixpkgs/master"; + + outputs = { self, nixpkgs }: + let + pkgs = import nixpkgs { system = "x86_64-linux"; }; + in + { + devShell.x86_64-linux = + let + libs = p: [ p.split p.HFuse p.aeson p.utf8-string ]; + in + pkgs.mkShell { + nativeBuildInputs = with pkgs; [ (haskellPackages.ghcWithPackages libs) ]; + }; + }; +} diff --git a/main.hs b/main.hs new file mode 100644 index 0000000..48ef004 --- /dev/null +++ b/main.hs @@ -0,0 +1,231 @@ +import Data.List.Split +import Data.List +import Control.Exception +import Data.Text (pack, unpack) + +import System.Fuse +import Foreign.C.Error +import System.Posix.Types +import System.Posix.Files +import System.Posix.IO + +import System.Process + +import qualified Data.Aeson as Aeson + +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Lazy.UTF8 (fromString, toString) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.Maybe as Maybe + +type Condition = (String, String) +data Request = AttrList | AttrVals String | View String [Condition] deriving (Show) + +data AnnexFile = AnnexFile { + file :: String, + fields :: HashMap.HashMap String [String] +} deriving (Show) + +instance Aeson.FromJSON AnnexFile where + parseJSON (Aeson.Object v) = + AnnexFile <$> v Aeson..: pack "file" + <*> v Aeson..: pack "fields" + +allFolderName = "all" +pathSep = "/" +repo = "/path/to/repo" + +parsePath :: String -> Request +parsePath path = + let + parts = filter (\part -> part /= "") (splitOn pathSep path) + (req, _) = foldl parseNext (AttrList, []) parts + in + req + +parseNext :: (Request, [Condition]) -> String -> (Request, [Condition]) +parseNext (current, conditions) str = + case current of + AttrList -> + if str == allFolderName then + (View "" conditions, []) + else + (AttrVals str, conditions) + AttrVals key -> + let + newConds = (key, str):conditions + in + (AttrList, newConds) + View path conditions -> + (View (path ++ (if path /= "" then pathSep else "") ++ str) conditions, []) + +type HT = () + +helloGetFileSystemStats :: String -> IO (Either Errno FileSystemStats) +helloGetFileSystemStats str = + return $ Right $ FileSystemStats { + fsStatBlockSize = 512, + fsStatBlockCount = 1, + fsStatBlocksFree = 1, + fsStatBlocksAvailable = 1, + fsStatFileCount = 5, + fsStatFilesFree = 10, + fsStatMaxNameLength = 255 + } + +dirStat ctx = FileStat { + statEntryType = Directory, + statFileMode = foldr1 unionFileModes [ + ownerReadMode, + ownerExecuteMode + ], + statLinkCount = 2, + statFileOwner = fuseCtxUserID ctx, + statFileGroup = fuseCtxGroupID ctx, + statSpecialDeviceID = 0, + statFileSize = 4096, + statBlocks = 1, + statAccessTime = 0, + statModificationTime = 0, + statStatusChangeTime = 0 +} + +fileStat ctx length = FileStat { + statEntryType = SymbolicLink, + statFileMode = foldr1 unionFileModes [ + ownerReadMode + ], + statLinkCount = 1, + statFileOwner = fuseCtxUserID ctx, + statFileGroup = fuseCtxGroupID ctx, + statSpecialDeviceID = 0, + statFileSize = length, + statBlocks = 1, + statAccessTime = 0, + statModificationTime = 0, + statStatusChangeTime = 0 +} + +helloGetFileStat :: FilePath -> IO (Either Errno FileStat) +helloGetFileStat path = + case (parsePath path) of + AttrList -> do + ctx <- getFuseContext + return $ Right $ dirStat ctx + AttrVals _ -> do + ctx <- getFuseContext + return $ Right $ dirStat ctx + View path _ -> do + ctx <- getFuseContext + tryFd <- try (openFd (repo ++ pathSep ++ path) ReadOnly Nothing defaultFileFlags) :: IO (Either SomeException Fd) + result <- case tryFd of + Left e -> return $ Left eNOENT + Right fd -> do + status <- getFdStatus fd + case status of + _ | isRegularFile status -> return $ Right $ fileStat ctx 1 + | isDirectory status -> return $ Right $ dirStat ctx + | otherwise -> return $ Left eNOENT + return $ result + +getFilterKeys :: [AnnexFile] -> [String] +getFilterKeys files = + let + fn AnnexFile{fields=fields} = fields + listsOfFields = map fn files + listsOfKeys = foldl (\a f -> a ++ HashMap.keys f) [] listsOfFields + goodFields = filter (\e -> not $ isSuffixOf "lastchanged" e) listsOfKeys + in + nub goodFields + +getFilterMap :: [AnnexFile] -> HashMap.HashMap String (HashSet.HashSet String) +getFilterMap files = + let + insertFieldsIntoMap map (name, values) = HashMap.insertWith (\new old -> HashSet.union new old) name (HashSet.fromList values) map + processFile res AnnexFile{file=filename,fields=fields} = + let + valueFields = HashMap.filterWithKey (\k _ -> not $ isSuffixOf "lastchanged" k) fields + in + foldl insertFieldsIntoMap res (HashMap.toList valueFields) + in + foldl (\res f -> processFile res f) HashMap.empty files + +filterFiles :: [AnnexFile] -> String -> [Condition] -> [AnnexFile] +filterFiles files (path) conditions = + let + matchPath AnnexFile{file=name} = isPrefixOf path name + matchConditions AnnexFile{fields=fields} = all (\(ck, cv) -> any (\(k, vs) -> any (\v -> ck == k && cv == v) vs) (HashMap.toList fields)) conditions + in + filter (\f -> matchPath f && matchConditions f) files + +helloFSOps :: (HashMap.HashMap String (HashSet.HashSet String)) -> [AnnexFile] -> FuseOperations HT +helloFSOps filterMap files = defaultFuseOps { + fuseGetFileStat = helloGetFileStat, + fuseReadSymbolicLink = my_readSymbolicLink, + fuseOpenDirectory = helloOpenDirectory filterMap, + fuseReadDirectory = helloReadDirectory filterMap files, + fuseGetFileSystemStats = helloGetFileSystemStats +} + +my_readSymbolicLink :: FilePath -> IO (Either Errno FilePath) +my_readSymbolicLink path = + let + request = parsePath path + in + return $ case request of + View path conditions -> Right $ repo ++ pathSep ++ path + _ -> Left $ eNOENT + +helloOpenDirectory filterMap path = + let + request = parsePath path + in + return $ case request of + AttrList -> eOK + AttrVals attr -> eOK + View path conditions -> + case path of + _ -> eOK + --_ -> eNOENT + +data EntityType = File | Folder deriving (Eq, Show) + +getFilename :: String -> AnnexFile -> (String, EntityType) +getFilename path AnnexFile{file=name} = + let + prefix = if path == "" then "" else (path ++ pathSep) + stripped = Maybe.fromJust (stripPrefix prefix name) + baseName = takeWhile (\e -> e /= (head pathSep)) stripped + in + if baseName == stripped then + (baseName, File) + else + (baseName, Folder) + +helloReadDirectory :: (HashMap.HashMap String (HashSet.HashSet String)) -> [AnnexFile] -> FilePath -> IO (Either Errno [(FilePath, FileStat)]) +helloReadDirectory filterMap files path = do + ctx <- getFuseContext + return $ case (parsePath path) of + AttrList -> + Right $ map (\attr -> (attr, dirStat ctx)) ([allFolderName, ".", ".."] ++ (HashMap.keys filterMap)) + AttrVals attr -> + case HashMap.lookup attr filterMap of + Just values -> Right $ map (\value -> (value, dirStat ctx)) ([".", ".."] ++ HashSet.toList values) + Nothing -> Left eNOENT + View path conditions -> + case path of + _ -> Right $ map (\(a, t) -> (a, (case t of Folder -> dirStat ctx; File -> fileStat ctx 1))) ([(".", Folder), ("..", Folder)] ++ nub (map (getFilename path) (filterFiles files path conditions))) + --_ -> Left eNOENT + +helloOpen :: FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno HT) +helloOpen path mode flags = return (Left eNOENT) + +helloRead :: FilePath -> HT -> ByteCount -> FileOffset -> IO (Either Errno B.ByteString) +helloRead _ _ _ _ = return $ Left eNOENT + +main :: IO () +main = do + a <- readCreateProcess ((shell "git annex metadata --json | jq '{ file: .file, fields: .fields}' | jq -s .") { cwd = Just repo }) "" + case (Aeson.decode (fromString a) :: Maybe [AnnexFile]) of + Just a -> fuseMain (helloFSOps (getFilterMap a) a) (\e -> print e >> defaultExceptionHandler e)