1 files changed, 97 insertions, 0 deletions
diff --git a/source/Felix/RequestDump.hs b/source/Felix/RequestDump.hs
new file mode 100644
index 0000000..312e1da
--- /dev/null
+++ b/source/Felix/RequestDump.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Exact prepared-request dump publication.
+module Felix.RequestDump
+    ( DumpObservationError(..)
+    , prepareRequestObserver
+    , captureDumpFailure
+    , renderDumpObservationError
+    ) where
+
+import Base
+import Felix.Output.Atomic (writeBytesAtomically)
+import Felix.OutputPlan qualified as Output
+import Felix.Verification
+    ( VerificationRequestObserver
+    , verificationRequestObserver
+    )
+import Felix.Provers
+
+import Control.Exception (displayException)
+import Control.Exception qualified as Exception
+import Data.Text qualified as Text
+import System.Directory qualified as Directory
+import System.FilePath.Posix qualified as Posix
+
+data DumpObservationError
+    = DumpDirectoryCreationFailed !FilePath !Text
+    | DumpRequestWriteFailed !WorkPosition !FilePath !Text
+    deriving stock (Show, Eq)
+
+instance Exception.Exception DumpObservationError
+
+prepareRequestObserver
+    :: Maybe Output.DumpOutputPlan
+    -> IO (Either DumpObservationError VerificationRequestObserver)
+prepareRequestObserver = \case
+    Nothing ->
+        pure
+            (Right
+                (verificationRequestObserver
+                    (\_position _request -> pure ())))
+    Just dumpPlan -> do
+        let root = Output.dumpOutputPath dumpPlan
+        created <- tryIOError
+            (Directory.createDirectoryIfMissing True root)
+        pure case created of
+            Left failure ->
+                Left
+                    (DumpDirectoryCreationFailed
+                        root
+                        (Text.pack (displayException failure)))
+            Right () ->
+                Right (verificationRequestObserver (writeDumpRequest root))
+
+writeDumpRequest
+    :: FilePath
+    -> WorkPosition
+    -> PreparedVerificationRequest
+    -> IO ()
+writeDumpRequest root position request = do
+    let destination =
+            root
+                Posix.</> ( show (workPositionModuleOrdinal position)
+                            <> "-"
+                            <> show (workPositionLocalRequestOrdinal position)
+                         )
+                Posix.<.> "p"
+    tryIOError
+        (writeBytesAtomically
+            destination
+            (preparedVerificationBytes request)) >>= \case
+                Left failure ->
+                    Exception.throwIO
+                        (DumpRequestWriteFailed
+                            position
+                            destination
+                            (Text.pack (displayException failure)))
+                Right () -> pure ()
+
+captureDumpFailure
+    :: IO value
+    -> IO (Either DumpObservationError value)
+captureDumpFailure = Exception.try
+
+renderDumpObservationError :: DumpObservationError -> Text
+renderDumpObservationError = \case
+    DumpDirectoryCreationFailed path message ->
+        "Could not create dump directory "
+            <> Text.pack (show path)
+            <> ": "
+            <> message
+    DumpRequestWriteFailed _position path message ->
+        "Could not write request dump "
+            <> Text.pack (show path)
+            <> ": "
+            <> message