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

275 lines
9.2 KiB
Haskell
Raw Normal View History

2020-01-23 07:16:09 +03:00
{-|
UNIX Filesystem Driver
-}
module Urbit.Vere.Clay
( clay
, clay'
)
where
2020-01-23 07:16:09 +03:00
import Urbit.Arvo hiding (Term)
import Urbit.King.App
import Urbit.Prelude
import Urbit.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
2020-01-23 07:16:09 +03:00
--------------------------------------------------------------------------------
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
2020-01-23 07:16:09 +03:00
-- | The hard coded mime type of every file.
textPlain = Path [(MkKnot "text"), (MkKnot "plain")]
2020-01-23 07:16:09 +03:00
-- | 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)
2020-01-23 07:16:09 +03:00
{-|
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
2020-01-23 07:16:09 +03:00
{-|
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)
2020-01-23 07:16:09 +03:00
{-|
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
2020-01-23 07:16:09 +03:00
{-|
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)
2020-01-23 07:16:09 +03:00
{-|
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)
--------------------------------------------------------------------------------
_boatFailed :: e -> WorkError -> IO ()
_boatFailed env _ = runRIO env $ do
pure () -- TODO What can we do?
clay'
:: HasPierEnv e
=> RIO e ([Ev], RAcquire e (DriverApi SyncEf))
clay' = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = clay env (writeTQueue ventQ)
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
clay
:: forall e
. (HasPierConfig e, HasLogFunc e, HasKingId e)
=> e
-> (EvErr -> STM ())
-> ([Ev], RAcquire e (SyncEf -> IO ()))
clay env plan =
(initialEvents, runSync)
where
2020-05-13 22:35:57 +03:00
king = fromIntegral (env ^. kingIdL)
boatEv = 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.
initialEvents = [boatEv]
2020-06-07 02:34:27 +03:00
runSync :: RAcquire e (SyncEf -> IO ())
2019-09-13 23:06:13 +03:00
runSync = handleEffect <$> mkRAcquire start stop
start :: RIO e ClayDrv
2019-09-13 03:08:04 +03:00
start = ClayDrv <$> newTVarIO mempty
stop c = pure ()
2020-06-07 02:34:27 +03:00
handleEffect :: ClayDrv -> SyncEf -> IO ()
handleEffect cd = runRIO env . \case
SyncEfHill _ mountPoints -> do
logDebug $ displayShow ("(clay) known mount points:", mountPoints)
pierPath <- view pierPathL
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
pierPath <- view pierPathL
let dir = pierPath </> deskToPath desk
actions <- buildActionListFromDifferences dir snapshot
logDebug $ displayShow ("(clay) dirk actions: ", actions)
let !intoList = map (actionsToInto dir) actions
let syncEv = EvBlip
$ BlipEvSync
$ SyncEvInto (Some (king, ())) desk False intoList
let syncFailed _ = pure ()
atomically $ plan (EvErr syncEv syncFailed)
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
pierPath <- view pierPathL
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)
pierPath <- view pierPathL
removeDirectoryRecursive $ pierPath </> deskToPath desk
atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
2019-09-13 21:02:41 +03:00
-- 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 21:02:41 +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)))
2019-09-13 21:02:41 +03:00
| 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
2019-09-13 21:02:41 +03:00
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