urbit/pkg/king/lib/Vere/Clay.hs

216 lines
8.2 KiB
Haskell
Raw Normal View History

module Vere.Clay (clay) where
import Arvo hiding (Term)
import UrbitPrelude
import Vere.Pier.Types
import Conduit
import RIO.Directory
import RIO.FilePath
import qualified Data.Conduit.Combinators as CC
import qualified Data.Map.Strict as M
import qualified Data.Set as S
data ClayDrv = ClayDrv
2019-09-13 03:08:04 +03:00
{ cdMountPoints :: TVar (Map Desk (Map FilePath Int))
}
deskToPath :: Desk -> FilePath
deskToPath (Desk (Cord t)) = unpack t
-- The hard coded mime type of every file.
textPlain = Path [(MkKnot "text"), (MkKnot "plain")]
-- Filter for dotfiles, tempfiles and backup files.
validClaySyncPath :: FilePath -> Bool
validClaySyncPath fp = hasPeriod && notTildeFile && notDotHash && notDoubleHash
where
fileName = takeFileName fp
hasPeriod = elem '.' fileName
notTildeFile = not $ "~" `isSuffixOf` fileName
notDotHash = not $ ".#" `isPrefixOf` fileName
notDoubleHash =
not $ ("#" `isPrefixOf` fileName) && ("#" `isSuffixOf` fileName)
-- Returns a list of the result of running a function on each valid file in the
-- directory fp. Runnable in IO.
foreachFileIn :: (MonadUnliftIO m)
=> FilePath -> (FilePath -> (ResourceT m) a) -> m [a]
foreachFileIn fp fun =
runConduitRes $ (sourceDirectoryDeep False fp)
.| filterC validClaySyncPath
.| CC.mapM fun
.| sinkList
-- Note: Vere just reuses +mug, but since the actual hash function is an
-- implementation detail which doesn't leave the io driver, we just use the
-- standard hash.
getHashOfFile :: (MonadIO m) => FilePath -> m (FilePath, Int)
getHashOfFile fp = do
bs <- readFile fp
let !h = hash bs
pure (fp, h)
-- Takes an initial snapshot of the filesystem, recording what files exist and
-- what their hashes are.
2019-09-13 03:08:04 +03:00
takeFilesystemSnapshot :: FilePath -> RIO e (Map FilePath Int)
takeFilesystemSnapshot fp = do
exists <- doesDirectoryExist fp
if not exists then
pure M.empty
else
M.fromList <$> foreachFileIn fp getHashOfFile
-- Check an existing filepath against a snapshot of files that existed on disk
-- the last time we checked. Returns Either (unchanged) (new file data).
checkFileForUpdates :: (MonadIO m)
2019-09-13 03:08:04 +03:00
=> Map FilePath Int -> FilePath
-> m (Either FilePath (FilePath, Mime, Int))
checkFileForUpdates snapshot fp = do
bs <- readFile fp
let !newHash = hash bs
2019-09-13 03:08:04 +03:00
pure $ case lookup fp snapshot of
-- text/plain is the hardcoded mime type of every file sent to clay.
Nothing -> Right (fp, (Mime textPlain (File (Octs bs))), newHash)
Just i -> if i == newHash then Left fp
else Right (fp, (Mime textPlain (File (Octs bs))), newHash)
-- Given a previous snapshot of the filesystem, produces a list of changes
2019-09-13 03:08:04 +03:00
buildActionListFromDifferences :: FilePath -> Map FilePath Int
-> RIO e [(FilePath, Maybe (Mime, Int))]
buildActionListFromDifferences fp snapshot = do
checks <- foreachFileIn fp (checkFileForUpdates snapshot)
2019-09-13 03:08:04 +03:00
let changedItems = rights checks <&> \(fp, m, i) -> (fp, Just (m, i))
let existsSet = S.fromList $ flip map checks $ \case
Left fp -> fp
Right (fp, _, _) -> fp
let deletedSet = S.difference (M.keysSet snapshot) existsSet
2019-09-13 03:08:04 +03:00
let deletedItems = (toList deletedSet) <&> \x -> (x, Nothing)
pure $ sort (deletedItems ++ changedItems)
--------------------------------------------------------------------------------
clay :: forall e. HasLogFunc e
=> FilePath -> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e SyncEf))
clay pierPath king enqueueEv =
(initialEvents, runSync)
where
initialEvents = [
EvBlip $ BlipEvBoat $ BoatEvBoat () ()
-- TODO: In the case of -A, we need to read all the data from the
-- specified directory and shove it into an %into event.
]
runSync :: RAcquire e (EffCb e SyncEf)
runSync = do
tim <- mkRAcquire start stop
pure (handleEffect tim)
-- TODO: Traditionally, lock file acquisition was handled in the unix
-- driver. This should instead be bumped up to main or something.
start :: RIO e ClayDrv
2019-09-13 03:08:04 +03:00
start = ClayDrv <$> newTVarIO mempty
stop c = pure ()
handleEffect :: ClayDrv -> SyncEf -> RIO e ()
handleEffect cd = \case
SyncEfHill _ mountPoints -> do
logDebug $ displayShow ("(clay) known mount points:", mountPoints)
mountPairs <- flip mapM mountPoints $ \desk -> do
ss <- takeFilesystemSnapshot (pierPath </> (deskToPath desk))
pure (desk, ss)
atomically $ writeTVar (cdMountPoints cd) (M.fromList mountPairs)
SyncEfDirk p desk -> do
logDebug $ displayShow ("(clay) dirk:", p, desk)
m <- atomically $ readTVar (cdMountPoints cd)
let snapshot = M.findWithDefault M.empty desk m
let dir = pierPath </> deskToPath desk
actions <- buildActionListFromDifferences dir snapshot
logDebug $ displayShow ("(clay) dirk actions: ", actions)
let !intoList = map (actionsToInto dir) actions
atomically $ enqueueEv $ EvBlip $ BlipEvSync $
SyncEvInto (Some (king, ())) desk False intoList
atomically $ modifyTVar
(cdMountPoints cd)
(applyActionsToMountPoints desk actions)
SyncEfErgo p desk actions -> do
logDebug $ displayShow ("(clay) ergo:", p, desk, actions)
m <- atomically $ readTVar (cdMountPoints cd)
let mountPoint = M.findWithDefault M.empty desk m
let dir = pierPath </> deskToPath desk
let hashedActions = map (calculateActionHash dir) actions
for_ hashedActions (performAction mountPoint)
atomically $ modifyTVar
(cdMountPoints cd)
(applyActionsToMountPoints desk hashedActions)
SyncEfOgre p desk -> do
logDebug $ displayShow ("(clay) ogre:", p, desk)
removeDirectoryRecursive $ pierPath </> deskToPath desk
atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
-- Change the structures off of the event into something we can work with in Unix.
calculateActionHash :: FilePath -> (Path, Maybe Mime) -> (FilePath, Maybe (Mime, Int))
calculateActionHash base (p, Nothing) = (base </> pathToFilePath p, Nothing)
calculateActionHash base (p, Just (Mime t f)) =
(base </> pathToFilePath p, Just ((Mime t f), (hash $ unOcts $ unFile f)))
-- Performs the actions on the actual filesystem
2019-09-13 03:08:04 +03:00
performAction :: (Map FilePath Int) -> (FilePath, Maybe (Mime, Int)) -> RIO e ()
performAction m (fp, Nothing) = do
logDebug $ displayShow ("(clay) deleting file ", fp)
removeFile fp
performAction m (fp, Just ((Mime _ (File (Octs bs)), hash)))
| skip =
logDebug $ displayShow ("(clay) skipping unchanged file update " , fp)
| otherwise = do
logDebug $ displayShow ("(clay) updating file " , fp)
createDirectoryIfMissing True $ takeDirectory fp
writeFile fp bs
where
skip = case M.lookup fp m of
Nothing -> False
Just i -> i == hash
-- Apply the actions to our internal snapshots
applyActionsToMountPoints :: Desk
-> [(FilePath, Maybe (Mime, Int))]
2019-09-13 03:08:04 +03:00
-> (Map Desk (Map FilePath Int))
-> (Map Desk (Map FilePath Int))
applyActionsToMountPoints desk actions m = M.alter change desk m
where
change (Just fileMap) = Just (foldl' applySyncAction fileMap actions)
change Nothing = change (Just M.empty)
-- Applies the sync mutations specified.
2019-09-13 03:08:04 +03:00
applySyncAction :: (Map FilePath Int)
-> (FilePath, Maybe (Mime, Int))
2019-09-13 03:08:04 +03:00
-> (Map FilePath Int)
applySyncAction m (fp, Nothing) = M.delete fp m
applySyncAction m (fp, (Just (_, h))) = M.insert fp h m
-- Changes an action list item into a form injectable into Urbit
actionsToInto :: FilePath -> (FilePath, Maybe (Mime, Int)) -> (Path, Maybe Mime)
actionsToInto prefix (fp, mybData) = (p, mybOutData)
where
p = filePathToPath strippedFp
strippedFp = case stripPrefix prefix fp of
Nothing -> error "Impossible missing prefix"
Just x -> x
mybOutData = case mybData of
Nothing -> Nothing
Just (m, i) -> Just m