ztail-1.0.1: TailHandle.hs

{-# LANGUAGE CPP, DeriveDataTypeable #-}
module TailHandle (
  runTail
  ) where

import Control.Monad
import System.Posix.Types
import System.Posix.Files
import System.Posix.IO
import System.IO.Error
import qualified Data.Maybe
import GHC.IO.Handle (SeekMode(AbsoluteSeek))
import Control.Concurrent
import qualified Control.Exception
import qualified Data.Typeable
#ifdef INOTIFY
import qualified System.INotify as INotify
#endif
import Data.IORef

import Util
import TailTypes

data TailHandle = TailHandle{
  thTail :: Tail,
  thRuntime :: TailRuntime,
  thPoll :: ThreadId,
  thReopen :: Maybe ThreadId,
  thFd :: Maybe Fd,
  thPos :: FileOffset,
  thIno :: Maybe FileID,
  thBuf :: String,
  thAgain :: Bool,
#ifdef INOTIFY
  thPollWatch :: Maybe INotify.WatchDescriptor,
  thReopenWatch :: Maybe INotify.WatchDescriptor,
#endif
  thSigPending :: IORef (Maybe TailSignal),
  thSigHandler :: IO () -> IO ()
}

data TailSignal = PollSignal | ReopenSignal deriving (Show, Data.Typeable.Typeable, Eq, Ord)
instance Control.Exception.Exception TailSignal

thErrMsg = tailErrMsg . thTail

catchDoesNotExist :: IO a -> IO (Maybe a)
catchDoesNotExist f = catchWhen isDoesNotExistError (liftM Just f) (return Nothing)

bad = ioError . userError

closeTail :: TailHandle -> IO TailHandle
closeTail th@TailHandle{ thFd = Nothing } = return th
closeTail th@TailHandle{ thFd = Just fd } = do
#ifdef INOTIFY
  whenJust rm_watch (thPollWatch th)
  whenJust rm_watch (thReopenWatch th)
#endif
  closeFd fd
  return th{
    thFd = Nothing
  , thPos = 0
  , thIno = Nothing
#ifdef INOTIFY
  , thPollWatch = Nothing
  , thReopenWatch = Nothing 
#endif
  }
#ifdef INOTIFY
  where
    rm_watch = INotify.removeWatch (Data.Maybe.fromJust (trINotify (thRuntime th)))
#endif

seekTail :: FileOffset -> TailHandle -> IO TailHandle
seekTail _ TailHandle{ thFd = Nothing } = bad "seek on closed fd"
seekTail c th@TailHandle{ thFd = Just fd } =
  fdSeek fd AbsoluteSeek c >. th{ thPos = c }

inotifyTail :: TailHandle -> IO TailHandle
#ifdef INOTIFY
inotifyTail th@TailHandle{ 
    thRuntime = TailRuntime{ trINotify = Just inotify },
    thPoll = tid,
    thTail = Tail{
      tailTarg = TailPath path,
      tailPollINotify = ipoll,
      tailReopenINotify = ireopen
    } } = do
  poll <- justWhen ipoll $
    INotify.addWatch inotify [INotify.Modify] path 
      (\_ -> Control.Exception.throwTo tid PollSignal)
  reopen <- justWhen ireopen $
    INotify.addWatch inotify [INotify.MoveSelf] path 
      (\_ -> Control.Exception.throwTo tid ReopenSignal)
  return th{
    thPollWatch = poll,
    thReopenWatch = reopen
  }
#endif
inotifyTail th = return th

openTail :: TailHandle -> IO TailHandle
openTail th@TailHandle{ thFd = Nothing } = get (tailTarg (thTail th)) where
  get (TailFd fd) = got (Just fd)
  get (TailPath path) = got =<<
    catchDoesNotExist (
      openFd path ReadOnly Nothing OpenFileFlags{
	append = False, exclusive = False, noctty = False, nonBlock = True, trunc = False
      })
  got Nothing = thErrMsg th "No such file or directory" >. th{ thPos = 0 }
  got (Just fd) = do
    setFdOption fd NonBlockingRead True
    go fd =<< getFdStatus fd
  go fd stat
    | isBlockDevice stat || isDirectory stat || isSymbolicLink stat =
      closeFd fd >> bad "unsupported file type"
    | isRegularFile stat =
      inotifyTail th' >>= seekTail (if pos < 0 then max 0 $ sz + 1 + pos else min sz pos)
    | otherwise =
      return th'{ thPos = -1 }
    where
      th' = th{ thFd = Just fd, thIno = Just (fileID stat), thAgain = True }
      sz = fileSize stat
      pos = thPos th
openTail _ = bad "open on opened tail"

reopenTail :: TailHandle -> IO TailHandle
reopenTail th@TailHandle{ thTail = Tail{ tailTarg = TailPath path }, thIno = ino } = do
  stat <- catchDoesNotExist $ getFileStatus path
  case stat of
    Nothing -> return th
    Just _ | ino == Nothing -> openTail th
    Just stat | ino == Just (fileID stat) -> return th
    Just stat | fileSize stat == 0 -> return th
    _ -> do
      thErrMsg th "Following new file"
      closeTail th >>= openTail
reopenTail th = return th

noRead :: TailHandle -> (TailHandle, [String])
noRead th = (th{ thAgain = False }, [])

bufsiz :: ByteCount
bufsiz = 8192

readTail :: TailHandle -> IO (TailHandle, [String])
readTail th@TailHandle{ thFd = Nothing } = return (noRead th)
readTail th@TailHandle{ thFd = Just fd, thPos = pos } =
  if pos == -1
    then catchWhen isEOFError readsock $ do
      checkbuf th >.= noRead
      -- thErrMsg th "closed?"
      -- closeTail th >.= noRead th
    else getFdStatus fd >.= fileSize >>= gotlen
  where
    checkbuf th@TailHandle{ thBuf = buf } = do
      when (buf /= "") $
	thErrMsg th ("Unterminated line: " ++ buf)
      return th{ thBuf = "" }
    gotlen len
      | len < pos = do
          thErrMsg th ("File truncated to " ++ show len)
	  seekTail 0 th >>= readTail
      | len == pos = do
	  checkbuf th >.= noRead
      | otherwise = do
	  let count = min (fromIntegral (len - pos)) bufsiz
	  (buf, buflen) <- readit (fromIntegral count)
	  when (buflen /= count) $
	    thErrMsg th ("Short read (" ++ show buflen ++ "/" ++ show count ++ ")")
	  return $ gotbuf th{ thPos = pos + fromIntegral buflen, thAgain = buflen == bufsiz } buf
    readsock =
      readit bufsiz >.= fst >.= gotbuf th{ thAgain = True }
    gotbuf th "" = noRead th
    gotbuf th@TailHandle{ thBuf = oldbuf } buf =
      case initlast $ split (== '\n') buf of
	([], r) ->
	  (th{ thBuf = oldbuf ++ r }, [])
	(l1 : l, r) ->
	  (th{ thBuf = r }, (oldbuf ++ l1) : l)
    readit len = catchWhen isFullError
      (fdRead fd len)
      (return ("", 0))

pause :: IO ()
pause = threadDelay (30*60*1000000) -- fixme how? (-1) doesn't work

waitTail :: TailHandle -> IO ()
waitTail TailHandle{ thFd = Nothing } = pause
waitTail TailHandle{ thFd = Just fd, thPos = -1 } = threadWaitRead fd
waitTail TailHandle{ thTail = t, thAgain = again } = do
  if again
    then yield 
    else if i == 0
      then pause
      else threadDelay i
  where 
    i = fromInterval (tailPollInterval t)

reopenThread :: Int -> ThreadId -> IO ()
reopenThread ri tid = forever $ do
  threadDelay ri
  Control.Exception.throwTo tid ReopenSignal

newTail :: TailRuntime -> Tail -> IO TailHandle
newTail tr tail = do
  tid <- myThreadId
  rid <- justWhen (ri /= 0) $ forkIO (reopenThread ri tid)
  sigpend <- newIORef Nothing
  return TailHandle{
    thTail = tail,
    thRuntime = tr,
    thPoll = tid,
    thReopen = rid,
    thFd = Nothing,
    thPos = if tailBegin tail then 0 else -1,
    thIno = Nothing,
    thBuf = [],
    thAgain = True,
#ifdef INOTIFY
    thPollWatch = Nothing,
    thReopenWatch = Nothing,
#endif
    thSigPending = sigpend,
    thSigHandler = Control.Exception.handle (\s ->
      modifyIORef sigpend (max (Just s)))
  }
  where 
    ri = fromInterval (tailReopenInterval tail)

runTail :: TailRuntime -> Tail -> IO ()
runTail tr tail = Control.Exception.block $
  newTail tr tail >>=
  openTail >>= go >>= 
  \TailHandle{ thReopen = wid } -> whenJust killThread wid
  where
    catch th ReopenSignal = reopenTail th -- >>= wait
    catch th PollSignal = return th
    wait th = do
      sig <- readIORef (thSigPending th)
      writeIORef (thSigPending th) Nothing
      maybe 
	(Control.Exception.catch
	  (trUnlock tr $ waitTail th >. th) 
	  (catch th))
	(catch th)
	sig
    poll th
      | thReopen th == Nothing
	&& (thFd th == Nothing
	  || (thAgain th == False && thPos th /= -1
	    && fromInterval (tailPollInterval (thTail th)) == 0
#ifdef INOTIFY
	    && thPollWatch th == Nothing 
	    && thReopenWatch th == Nothing
#endif
	    ))
	= return th
      | otherwise = wait th >>= go
    go th = readTail th >>= proc >>= poll
    proc (th, s) = mapM_ (thSigHandler th . fun) s >. th
    fun = (trText tr) tail