SymLinks and Interpreters in Haskell

symlinks.hs

data SymLinkOpError = SymLinkOpErrorNonSymlink FilePath | SymLinkOpErrorTargetConflict
data SymLinkReadState = SymLinkReadAbsent | SymLinkReadNonSymLink | SymLinkReadPresent FilePath
data SymLinkOps m a where
    -- Given a Symlink location, returns its target
    ReadSymLink :: FilePath -> SymLinkOps m SymLinkReadState
    WriteSymLink :: FilePath -> FilePath -> SymLinkOps m ()
    RemoveSymLink :: FilePath -> SymLinkOps m ()

data AdvancedSymLinkOps m a where
    -- Create or replace a symlink; fails out if the symlink existed with a different path than anticipated
    -- Parameters: (Symlink location) -> (Expected old target) -> (New target) -> (bool of changed or created)
    UpdateSymLinkMatching :: FilePath -> Maybe FilePath -> FilePath -> AdvancedSymLinkOps m Bool
    -- Remove symlink if exists; fails out if the symlink existed with a different path than anticipated
    -- Does not fail if the symlink did not exist
    -- Parameters: (Symlink location) -> (Expected old target) -> (bool of removed)
    RemoveSymLinkMatching :: FilePath -> FilePath -> AdvancedSymLinkOps m Bool

makeSem ''SymLinkOps
makeSem ''AdvancedSymLinkOps

interpretAdvancedSymLinkOps :: (Member (Error SymLinkOpError) r, Member SymLinkOps r) => Sem (AdvancedSymLinkOps ': r) a -> Sem r a
interpretAdvancedSymLinkOps = interpret \case
    -- Handle symlink creation when no old-path is specified
    UpdateSymLinkMatching symloc Nothing newPath -> do
        readSymLink symloc >>= \case
            SymLinkReadNonSymLink -> PError.throw (SymLinkOpErrorNonSymlink symloc)
            SymLinkReadAbsent -> do
                writeSymLink symloc newPath
                return True
            SymLinkReadPresent _ ->
                -- Symlink present when expected to be absent
                PError.throw SymLinkOpErrorTargetConflict

    -- Handle symlink creation when an old-path is specified
    UpdateSymLinkMatching symloc (Just oldPath) newPath -> do
        readSymLink symloc >>= \case
            SymLinkReadNonSymLink -> PError.throw (SymLinkOpErrorNonSymlink symloc)
            SymLinkReadAbsent -> do
                writeSymLink symloc newPath
                return True
            -- Existing and new paths match; no-op (ignoring expected oldPath)
            SymLinkReadPresent target | target == newPath ->
                return False -- Unmodified
            -- New path differs, and old one matched current; replace.
            SymLinkReadPresent target | target == oldPath -> do
                -- Overwrite existing
                writeSymLink symloc newPath
                return True
            SymLinkReadPresent _ -> PError.throw SymLinkOpErrorTargetConflict

    RemoveSymLinkMatching symloc oldPath ->
        readSymLink symloc >>= \case
            SymLinkReadNonSymLink -> PError.throw (SymLinkOpErrorNonSymlink symloc)
            SymLinkReadPresent pointsAt | pointsAt /= oldPath ->
                PError.throw SymLinkOpErrorTargetConflict
            SymLinkReadAbsent -> return False
            SymLinkReadPresent _ -> do
                removeSymLink symloc
                return True


interpretSymLinkOpsInIO :: (Member (Embed IO) r, Member (Error SymLinkOpError) r) => Sem (SymLinkOps ': r) a -> Sem r a
interpretSymLinkOpsInIO = interpret \case
    ReadSymLink path -> do
        status <- embed $ try @IOError $ getSymbolicLinkStatus path
        case status of
            Right (isSymbolicLink -> False) -> PError.throw (SymLinkOpErrorNonSymlink path)
            Right _ -> do
                symSource <- embed $ readSymbolicLink path
                return $ SymLinkReadPresent symSource
            Left _ -> return SymLinkReadAbsent

    WriteSymLink path target -> do
        status <- embed $ try @IOError $ getSymbolicLinkStatus path
        case status of
            Right (isSymbolicLink -> False) -> PError.throw (SymLinkOpErrorNonSymlink path)
            Right _ -> do
                symSource <- embed $ readSymbolicLink path
                case symSource of
                    s | s == target -> return ()
                    _ -> embed $ do
                        removeFile path
                        createSymbolicLink path target
            Left _ -> embed $ createSymbolicLink path target

    RemoveSymLink path -> do
        status <- embed $ try @IOError $ getSymbolicLinkStatus path
        case status of
            Right (isSymbolicLink -> False) -> PError.throw (SymLinkOpErrorNonSymlink path)
            Right _ -> do
                embed $ removeFile path
            Left _ -> return ()


newtype FakeSymLinkFileContent = FakeSymLinkFileContent { symLinkTarget :: FilePath }
data FakeSymLinkEnvironmentFile = FakeNonSymFile | FakeSymLinkFile FakeSymLinkFileContent
type FakeSymLinkEnvironment = Map FilePath FakeSymLinkEnvironmentFile
interpretSymLinkOpsPure ::
    (Members [Trace.Trace, Error SymLinkOpError, S.State FakeSymLinkEnvironment] r) =>
    Sem (SymLinkOps ': r) a ->
    Sem r a
interpretSymLinkOpsPure = interpret \case
    -- ReadSymLink :: FilePath -> SymLinkOps m SymLinkReadState
    ReadSymLink path -> do
        Trace.trace $ "Reading path " ++ path
        env <- S.get @FakeSymLinkEnvironment
        case Map.lookup path env of
            Nothing -> do
                Trace.trace "  Path was unoccupied"
                return SymLinkReadAbsent
            Just FakeNonSymFile -> do
                Trace.trace "  Path contained non-symlink"
                return SymLinkReadNonSymLink
            Just (FakeSymLinkFile (FakeSymLinkFileContent { symLinkTarget = target })) -> do
                Trace.trace $ "  Path contained symlink to " ++ target
                return $ SymLinkReadPresent target

    -- WriteSymLink :: FilePath -> FilePath -> SymLinkOps m ()
    WriteSymLink path target -> do
        Trace.trace $ "Writing symlink at path " ++ path ++ " to target " ++ target
        env <- S.get @FakeSymLinkEnvironment
        case Map.lookup path env of
            Nothing -> do
                S.put @FakeSymLinkEnvironment $ Map.insert path (FakeSymLinkFile $ FakeSymLinkFileContent { symLinkTarget = target }) env
                Trace.trace "  Created new symlink file at unoccupied path"
            Just FakeNonSymFile -> PError.throw $ SymLinkOpErrorNonSymlink path
            Just (FakeSymLinkFile (FakeSymLinkFileContent { symLinkTarget = oldTarget })) -> do
                S.put @FakeSymLinkEnvironment $ Map.insert path (FakeSymLinkFile $ FakeSymLinkFileContent { symLinkTarget = target }) env
                Trace.trace $ "  Replaced symlink to " ++ oldTarget
        
    -- RemoveSymLink :: FilePath -> SymLinkOps m ()
    RemoveSymLink path -> do
        Trace.trace $ "Removing symlink at path " ++ path
        env <- S.get @FakeSymLinkEnvironment
        case Map.lookup path env of
            Nothing -> Trace.trace "  Symlink was not present in environment"
            Just FakeNonSymFile -> PError.throw $ SymLinkOpErrorNonSymlink path
            Just (FakeSymLinkFile (FakeSymLinkFileContent { symLinkTarget = target })) -> do
                S.put $ Map.delete path env
                Trace.trace $ "  Deleted symlink to " ++ target