path: root/source/Felix/OutputPlan.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Authority-free reservation of verification output namespaces.
module Felix.OutputPlan
    ( DumpOutputPlan
    , dumpOutputPath
    , VerificationOutputPlan
    , verificationDumpOutput
    , verificationHtmlRoutes
    , OutputNamespaceOwner(..)
    , OutputNamespaceCollision(..)
    , OutputPlanError(..)
    , renderOutputPlanError
    , planVerificationOutputs
    ) where

import Base
import Felix.Source
import Felix.Store
import Felix.Render.Html.Output qualified as Html

import Control.Exception (displayException)
import Data.List qualified as List
import Data.Text qualified as Text
import System.Directory qualified as Directory
import System.FilePath.Posix qualified as Posix


newtype DumpOutputPlan = DumpOutputPlan FilePath
    deriving stock (Show, Eq)

dumpOutputPath :: DumpOutputPlan -> FilePath
dumpOutputPath (DumpOutputPlan path) =
    path

data VerificationOutputPlan = VerificationOutputPlan
    !(Maybe DumpOutputPlan)
    !(Maybe Html.HtmlRoutePlan)

verificationDumpOutput
    :: VerificationOutputPlan
    -> Maybe DumpOutputPlan
verificationDumpOutput
        (VerificationOutputPlan dump _html) =
    dump

verificationHtmlRoutes
    :: VerificationOutputPlan
    -> Maybe Html.HtmlRoutePlan
verificationHtmlRoutes
        (VerificationOutputPlan _dump html) =
    html

data OutputNamespaceOwner
    = StoreOutputNamespace
    | StoreJournalOutputNamespace
    | DumpOutputNamespace
    | HtmlOutputArtifact !SafeRelativePath
    deriving stock (Show, Eq, Ord)

data OutputNamespaceCollision = OutputNamespaceCollision
    !OutputNamespaceOwner
    !FilePath
    !OutputNamespaceOwner
    !FilePath
    deriving stock (Show, Eq)

data OutputPlanError
    = EmptyDumpDestination
    | OutputPathInspectionFailed !FilePath !Text
    | DumpDestinationNotDirectory !FilePath
    | DumpDestinationNotEmpty !FilePath ![FilePath]
    | HtmlRoutePlanFailed !Html.HtmlOutputError
    | CollidingOutputNamespaces
        !(NonEmpty OutputNamespaceCollision)
    deriving stock (Show, Eq)

renderOutputPlanError :: OutputPlanError -> Text
renderOutputPlanError = \case
    EmptyDumpDestination ->
        "--dump requires a nonempty destination"
    OutputPathInspectionFailed path reason ->
        "could not inspect output path " <> quotePath path <> ": " <> reason
    DumpDestinationNotDirectory path ->
        "dump destination is not a directory: " <> quotePath path
    DumpDestinationNotEmpty path contents ->
        "dump destination " <> quotePath path
            <> " is not empty; choose an absent or empty directory"
            <> case contents of
                [] -> ""
                _ -> "; found "
                    <> Text.intercalate ", " (quotePath <$> contents)
    HtmlRoutePlanFailed failure ->
        Html.renderHtmlOutputError failure
    CollidingOutputNamespaces collisions ->
        "verification output namespaces collide: "
            <> Text.intercalate "; "
                (renderCollision <$> toList collisions)
  where
    renderCollision
        (OutputNamespaceCollision leftOwner leftPath rightOwner rightPath) =
            renderOwner leftOwner <> " " <> quotePath leftPath
                <> " conflicts with " <> renderOwner rightOwner
                <> " " <> quotePath rightPath

    renderOwner = \case
        StoreOutputNamespace -> "store"
        StoreJournalOutputNamespace -> "store rollback journal"
        DumpOutputNamespace -> "dump directory"
        HtmlOutputArtifact relative ->
            "HTML artifact "
                <> quotePath (safeRelativePathFilePath relative)

quotePath :: FilePath -> Text
quotePath = Text.pack . show

planVerificationOutputs
    :: StorePath
    -> Maybe FilePath
    -> Maybe (FilePath, [SafeRelativePath])
    -> IO (Either OutputPlanError VerificationOutputPlan)
planVerificationOutputs storePath requestedDump requestedHtml = do
    dumpResult <- traverse planDumpOutput requestedDump
    case sequence dumpResult of
        Left failure ->
            pure (Left failure)
        Right dump -> do
            htmlResult <- traverse
                (uncurry Html.planHtmlRoutes)
                requestedHtml
            case sequence htmlResult of
                Left failure ->
                    pure (Left (HtmlRoutePlanFailed failure))
                Right html ->
                    pure do
                        rejectCollisions storePath dump html
                        Right
                            (VerificationOutputPlan
                                dump html)

planDumpOutput
    :: FilePath
    -> IO (Either OutputPlanError DumpOutputPlan)
planDumpOutput requested
    | null requested =
        pure (Left EmptyDumpDestination)
    | otherwise = do
        absoluteResult <- inspectPath requested
            (Posix.normalise
                <$> Directory.makeAbsolute requested)
        case absoluteResult of
            Left failure ->
                pure (Left failure)
            Right absolute -> do
                existsResult <- inspectPath absolute
                    (Directory.doesPathExist absolute)
                case existsResult of
                    Left failure ->
                        pure (Left failure)
                    Right False ->
                        pure (Right (DumpOutputPlan absolute))
                    Right True -> do
                        directoryResult <- inspectPath absolute
                            (Directory.doesDirectoryExist absolute)
                        case directoryResult of
                            Left failure ->
                                pure (Left failure)
                            Right False ->
                                pure
                                    (Left
                                        (DumpDestinationNotDirectory
                                            absolute))
                            Right True -> do
                                contentsResult <- inspectPath absolute
                                    (List.sort
                                        <$> Directory.listDirectory
                                            absolute)
                                pure
                                    (case contentsResult of
                                        Left failure ->
                                            Left failure
                                        Right [] ->
                                            Right
                                                (DumpOutputPlan absolute)
                                        Right contents ->
                                            Left
                                                (DumpDestinationNotEmpty
                                                    absolute
                                                    contents))

rejectCollisions
    :: StorePath
    -> Maybe DumpOutputPlan
    -> Maybe Html.HtmlRoutePlan
    -> Either OutputPlanError ()
rejectCollisions storePath dump html =
    case collisions of
        [] ->
            Right ()
        firstCollision : remaining ->
            Left
                (CollidingOutputNamespaces
                    (firstCollision :| remaining))
  where
    stores =
        [ ( StoreOutputNamespace
          , storePathFilePath storePath
          )
        , ( StoreJournalOutputNamespace
          , storeRollbackJournalPath storePath
          )
        ]
    dumpNamespace =
        (\planned ->
            ( DumpOutputNamespace
            , dumpOutputPath planned
            ))
            <$> dump
    htmlArtifacts =
        case html of
            Nothing ->
                []
            Just routes ->
                [ (HtmlOutputArtifact relative, destination)
                | (relative, destination) <-
                    Html.htmlRoutePlanDestinations routes
                ]
    pairs =
        maybe
            []
            (\dumpOwner ->
                [(storeOwner, dumpOwner) | storeOwner <- stores])
            dumpNamespace
            <> [ (storeOwner, htmlOwner)
               | storeOwner <- stores
               , htmlOwner <- htmlArtifacts
               ]
            <> maybe
                []
                (\dumpOwner ->
                    [(dumpOwner, htmlOwner) | htmlOwner <- htmlArtifacts])
                dumpNamespace
    collisions =
        [ OutputNamespaceCollision
            leftOwner leftPath rightOwner rightPath
        | ( (leftOwner, leftPath)
          , (rightOwner, rightPath)
          ) <- pairs
        , namespacesOverlap leftPath rightPath
        ]

namespacesOverlap :: FilePath -> FilePath -> Bool
namespacesOverlap left right =
    components left `List.isPrefixOf` components right
        || components right `List.isPrefixOf` components left
  where
    components =
        Posix.splitDirectories
            . Posix.dropTrailingPathSeparator
            . Posix.normalise

inspectPath
    :: FilePath
    -> IO value
    -> IO (Either OutputPlanError value)
inspectPath path action = do
    result <- tryIOError action
    pure
        (case result of
            Left failure ->
                Left
                    (OutputPathInspectionFailed
                        path
                        (Text.pack
                            (displayException failure)))
            Right value ->
                Right value)