never executed always true always false

    1 module PureClaw.Handles.Transcript
    2   ( -- * Handle type
    3     TranscriptHandle (..)
    4     -- * Implementations
    5   , mkFileTranscriptHandle
    6   , mkNoOpTranscriptHandle
    7   ) where
    8 
    9 import Control.Exception
   10 import Control.Monad
   11 import Data.Foldable qualified
   12 import Data.Aeson qualified as Aeson
   13 import Data.ByteString qualified as BS
   14 import Data.ByteString.Lazy qualified as LBS
   15 import Data.ByteString.Lazy.Char8 qualified as LBC
   16 import Data.IORef
   17 import Data.Text qualified as T
   18 import System.Directory
   19 import System.FilePath
   20 import System.IO.Error
   21 import System.Posix.Files
   22 import System.Posix.IO qualified as Posix
   23 import System.Posix.IO.ByteString qualified as PosixBS
   24 import System.Posix.Types
   25 
   26 import Foreign.C.Error
   27 import Foreign.C.Types
   28 
   29 import PureClaw.Handles.Log
   30 import PureClaw.Transcript.Types
   31 
   32 -- | POSIX fsync(2) — flush kernel buffers to disk.
   33 foreign import ccall "fsync" c_fsync :: CInt -> IO CInt
   34 
   35 fdSync :: Fd -> IO ()
   36 fdSync (Fd fd) = throwErrnoIfMinus1_ "fdSync" (c_fsync fd)
   37 
   38 -- | Transcript I/O capability. Append-only JSONL log with query support.
   39 data TranscriptHandle = TranscriptHandle
   40   { _th_record  :: TranscriptEntry -> IO ()
   41   , _th_query   :: TranscriptFilter -> IO [TranscriptEntry]
   42   , _th_getPath :: IO FilePath
   43   , _th_flush   :: IO ()
   44   , _th_close   :: IO ()
   45   }
   46 
   47 -- | File-backed transcript handle using JSONL format.
   48 mkFileTranscriptHandle :: LogHandle -> FilePath -> IO TranscriptHandle
   49 mkFileTranscriptHandle logger path = do
   50   -- Create parent directory with 0700 permissions if it doesn't exist
   51   let dir = takeDirectory path
   52   dirExists <- doesDirectoryExist dir
   53   unless dirExists $ do
   54     createDirectoryIfMissing True dir
   55     setFileMode dir 0o700
   56 
   57   -- Open file with 0600 permissions using raw POSIX fd (no GHC file locking)
   58   fd <- Posix.openFd path
   59     Posix.ReadWrite
   60     (Posix.defaultFileFlags { Posix.append = True, Posix.creat = Just 0o600 })
   61 
   62   closedRef <- newIORef False
   63   fdRef <- newIORef (Just fd)
   64 
   65   pure TranscriptHandle
   66     { _th_record = \entry -> do
   67         closed <- readIORef closedRef
   68         unless closed $ do
   69           mfd <- readIORef fdRef
   70           case mfd of
   71             Nothing -> pure ()
   72             Just wfd -> do
   73               let line = LBS.toStrict (Aeson.encode entry) <> "\n"
   74               void (PosixBS.fdWrite wfd line)
   75 
   76     , _th_query = \tf -> do
   77         closed <- readIORef closedRef
   78         if closed
   79           then pure []
   80           else do
   81             -- Read via a separate fd to avoid any conflicts
   82             contents <- readFileRaw path
   83             let rawLines = LBC.lines (LBS.fromStrict contents)
   84             decoded <- decodeLines logger rawLines
   85             pure (applyFilter tf decoded)
   86 
   87     , _th_getPath = pure path
   88 
   89     , _th_flush = do
   90         closed <- readIORef closedRef
   91         unless closed $ do
   92           mfd <- readIORef fdRef
   93           Data.Foldable.for_ mfd fdSync
   94 
   95     , _th_close = do
   96         closed <- readIORef closedRef
   97         unless closed $ do
   98           writeIORef closedRef True
   99           mfd <- readIORef fdRef
  100           writeIORef fdRef Nothing
  101           case mfd of
  102             Nothing -> pure ()
  103             Just wfd -> do
  104               fdSync wfd
  105               Posix.closeFd wfd
  106     }
  107 
  108 -- | Read a file strictly using raw POSIX fd operations, bypassing
  109 -- GHC RTS file locking to avoid conflicts with an already-open fd.
  110 readFileRaw :: FilePath -> IO BS.ByteString
  111 readFileRaw fp = do
  112   rfd <- Posix.openFd fp Posix.ReadOnly Posix.defaultFileFlags
  113   let chunkSize :: ByteCount
  114       chunkSize = 65536
  115       go acc = do
  116         result <- try (PosixBS.fdRead rfd chunkSize)
  117         case result of
  118           Left e
  119             | isEOFError e -> pure (BS.concat (reverse acc))
  120             | otherwise    -> throwIO e
  121           Right chunk
  122             | BS.null chunk -> pure (BS.concat (reverse acc))
  123             | otherwise     -> go (chunk : acc)
  124   contents <- go []
  125   Posix.closeFd rfd
  126   pure contents
  127 
  128 -- | Decode JSONL lines, skipping malformed ones and logging warnings.
  129 decodeLines :: LogHandle -> [LBS.ByteString] -> IO [TranscriptEntry]
  130 decodeLines logger = go
  131   where
  132     go [] = pure []
  133     go (line:rest)
  134       | LBS.null line = go rest
  135       | otherwise = case Aeson.eitherDecode line of
  136           Right entry -> (entry :) <$> go rest
  137           Left err    -> do
  138             _lh_logWarn logger ("Skipping malformed JSONL line: " <> T.pack err)
  139             go rest
  140 
  141 -- | No-op transcript handle for testing.
  142 mkNoOpTranscriptHandle :: TranscriptHandle
  143 mkNoOpTranscriptHandle = TranscriptHandle
  144   { _th_record  = \_ -> pure ()
  145   , _th_query   = \_ -> pure []
  146   , _th_getPath = pure ""
  147   , _th_flush   = pure ()
  148   , _th_close   = pure ()
  149   }