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

{-|
    UNIX Filesystem Driver
-}

module Urbit.Vere.Clay (clay) where

import Urbit.Arvo            hiding (Term)
import Urbit.King.App        (HasKingId(..))
import Urbit.King.Config
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


--------------------------------------------------------------------------------

data ClayDrv = ClayDrv
  { 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.
-}
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)
                    => Map FilePath Int -> FilePath
                    -> m (Either FilePath (FilePath, Mime, Int))
checkFileForUpdates snapshot fp = do
  bs <- readFile fp
  let !newHash = hash bs
  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
-}
buildActionListFromDifferences :: FilePath -> Map FilePath Int
                               -> RIO e [(FilePath, Maybe (Mime, Int))]
buildActionListFromDifferences fp snapshot = do
  checks <- foreachFileIn fp (checkFileForUpdates snapshot)

  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
  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
  :: forall e
   . (HasPierConfig e, HasLogFunc e, HasKingId e)
  => e
  -> (EvErr -> STM ())
  -> ([EvErr], RAcquire e (SyncEf -> IO ()))
clay env plan =
    (initialEvents, runSync)
  where
    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 = [EvErr boatEv (boatFailed env)]

    runSync :: RAcquire e (SyncEf -> IO ())
    runSync = handleEffect <$> mkRAcquire start stop

    start :: RIO e ClayDrv
    start = ClayDrv <$> newTVarIO mempty
    stop c = pure ()

    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)


    -- 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
    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))]
                              -> (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.
        applySyncAction :: (Map FilePath Int)
                        -> (FilePath, Maybe (Mime, Int))
                        -> (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