content: {-# OPTIONS_GHC -Wno-deprecations #-}
  
  -- |
  -- Module      : Streamly.Test.FileSystem.Event.Common
  -- Copyright   : (c) 2020 Composewell Technologies
  -- License     : BSD-3-Clause
  -- Maintainer  : streamly@composewell.com
  -- Stability   : experimental
  -- Portability : GHC
  --
  module Streamly.Test.FileSystem.Event.Common
      ( TestDesc
  
      -- * Running tests
      , runTests
      , WatchRootType (..)
  
      -- * Event predicates
      , dirEvent
      , fileEvent
  
      -- * Tests
      , dirCreate
      , dirCreateWithParent
      , dirDelete
      , dirMove
      , rootDirMove
  
      , fileCreate
      , fileCreateWithParent
      , fileDelete
      , fileModify
      , fileMove
      , rootFileMove
  
      , commonTests
      , commonRecTests
      )
  
  where
  
  import Debug.Trace (trace)
  import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)
  import Control.Monad (when)
  import Control.Monad.IO.Class (MonadIO)
  import Data.Bifunctor (first)
  import Data.Function ((&))
  import Data.Functor.Identity (runIdentity)
  import Data.List.NonEmpty (NonEmpty)
  import Data.Word (Word8)
  import Streamly.Data.Array (Array)
  import System.Directory
      ( createDirectory
      , createDirectoryIfMissing
      , createDirectoryLink
      , doesDirectoryExist
      , doesFileExist
      , removeFile
      , removePathForcibly
      , renameDirectory
      , renamePath
      )
  import System.FilePath ((</>), takeDirectory)
  import System.IO
      ( BufferMode(..), hSetBuffering, stdout, IOMode (WriteMode), openFile
      , hClose)
  import System.IO.Temp (withSystemTempDirectory)
  
  import qualified Data.List.NonEmpty as NonEmpty
  import qualified Streamly.Internal.Data.Array as Array
  import qualified Streamly.Internal.Data.Stream as Stream
  import qualified Streamly.Internal.Data.Stream.Prelude as Stream
  import qualified Streamly.Unicode.Stream as Unicode
  
  #if defined(FILESYSTEM_EVENT_LINUX)
  import Streamly.Internal.FileSystem.Event.Linux (Event)
  import qualified Streamly.Internal.FileSystem.Event.Linux as Event
  #elif defined(FILESYSTEM_EVENT_DARWIN)
  import Streamly.Internal.FileSystem.Event.Darwin (Event)
  import qualified Streamly.Internal.FileSystem.Event.Darwin as Event
  #elif defined(FILESYSTEM_EVENT_WINDOWS)
  import Streamly.Internal.FileSystem.Event.Windows (Event)
  import qualified Streamly.Internal.FileSystem.Event.Windows as Event
  #else
  import Streamly.Internal.FileSystem.Event (Event)
  import qualified Streamly.Internal.FileSystem.Event as Event
  #endif
  
  import Test.Hspec
  
  -------------------------------------------------------------------------------
  -- Check generated events
  -------------------------------------------------------------------------------
  
  type EventChecker =
         FilePath  -- watch root
      -> FilePath  -- watch target, target dir if root is a symlink
      -> MVar ()   -- mvar to sync file system ops and the watch
      -> [(String, Event -> Bool)] -- expected events
      -> IO ()
  type EventWatcher = NonEmpty (Array Word8) -> Stream.Stream IO Event.Event
  
  eventMatches :: Event -> (String, Event -> Bool) -> Bool
  eventMatches ev (expectedPath, f) =
      trace ("paths: " ++ show evPath ++ " " ++ show expectedPath)
          (evPath == expectedPath && f ev)
  
      where
  
      utf8ToString :: Array Word8 -> String
      utf8ToString =
          runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.read
  
      evPath = utf8ToString (Event.getAbsPath ev)
  
  toUtf8 :: MonadIO m => String -> m (Array Word8)
  toUtf8 = Array.fromStream . Unicode.encodeUtf8' . Stream.fromList
  
  checkEvents :: EventWatcher -> EventChecker
  checkEvents watcher rootPath targetPath mvar matchList = do
      putStrLn ("Watching on root [" <> rootPath
               <> "] for [" <> targetPath <> "]")
  
      let matchList1 = fmap (first (targetPath </>)) matchList
          finder xs ev = filter (not . eventMatches ev) xs
  
      paths <- mapM toUtf8 [rootPath]
      watcher (NonEmpty.fromList paths)
          & Stream.before (putMVar mvar ())
          & Stream.trace (putStrLn . Event.showEvent)
          & Stream.scanl' finder matchList1
          & Stream.takeWhile (not . null)
          & Stream.drain
  
  -------------------------------------------------------------------------------
  -- Run tests
  -------------------------------------------------------------------------------
  
  type TestDesc =
      ( String            -- test description
      , FilePath -> IO () -- pre test operation, arg is path of the watch root.
      , FilePath -> IO () -- file system action, arg is path of the watch root.
      , [(String, Event -> Bool)] -- expected events (Absolute Path, predicate)
      )
  
  -- | Whether watch root is a symlink and if so then what's the behavior
  data WatchRootType =
        DirType             -- watch root is a directory
      | FileType            -- watch root is a file
      | SymLinkResolvedPath -- symlink to a directory,
                            -- Event contains path via the resolved dir
      | SymLinkOrigPath     -- symlink to a directory,
                            -- Event contains path via the original symlink
      deriving Show
  
  driver :: EventChecker -> WatchRootType -> TestDesc -> SpecWith ()
  driver checker symlinkStyle (desc, pre, ops, expected) =
      it desc $ runOneTest `shouldReturn` ()
  
      where
  
      fseventDir :: String
      fseventDir = "fsevent_dir"
  
      runOneTest = do
              sync <- newEmptyMVar
              withSystemTempDirectory fseventDir $ \fp -> do
                  let root = fp </> "watch-root"
                  target <-
                      case symlinkStyle of
                          DirType -> do
                              createDirectory root
                              return root
                          FileType -> do
                              openFile root WriteMode >>= hClose
                              return root
                          SymLinkResolvedPath -> do
                              -- root -> target
                              let tgt = fp </> "watch-root-real"
                              createDirectory tgt
                              createDirectoryLink tgt root
                              return tgt
                          SymLinkOrigPath -> do
                              -- root -> target
                              let tgt = fp </> "watch-root-real"
                              createDirectory tgt
                              createDirectoryLink tgt root
                              return root
  
                  -- XXX On macOS we seem to get the watch root create events
                  -- even though they occur before the watch is started.  Even if
                  -- we add a delay here.
                  startWatchAndCheck root target sync
  
      startWatchAndCheck root target sync = do
              putStrLn ("Before pre op: root [" <> root
                      <> "] target [" <> target <> "]")
              pre root
              putStrLn ("After pre op: root [" <> root
                      <> "] target [" <> target <> "]")
              -- XXX On macOS the events from pre ops also seem to be bundled
              -- with the events occurred after the watch is started.
              let check = checker root target sync expected
                  fsOps = Stream.fromEffect $ runFSOps root sync
              Stream.drain
                  $ Stream.parListEagerFst [Stream.fromEffect check, fsOps]
  
      runFSOps fp sync = do
          -- We put the MVar before the event watcher starts to run but that does
          -- not ensure that the event watcher has actually started. So we need a
          -- delay as well. Do we?
          takeMVar sync >> threadDelay 200000
          putStrLn ("Before fs ops: root [" <> fp)
          ops fp
          putStrLn ("After fs ops: root [" <> fp)
          threadDelay 10000000
          error $ fp <> ": Time out occurred before event watcher could terminate"
  
  -------------------------------------------------------------------------------
  -- Test descriptions
  -------------------------------------------------------------------------------
  
  dirEvent, fileEvent :: (Event -> Bool) -> Event -> Bool
  
  #if defined(FILESYSTEM_EVENT_DARWIN)
  dirEvent f ev = Event.isDir ev && f ev
  fileEvent f ev = Event.isFile ev && f ev
  #elif defined(FILESYSTEM_EVENT_LINUX)
  dirEvent f ev = Event.isDir ev && f ev
  fileEvent f ev = not (Event.isDir ev) && f ev
  #else
  dirEvent = id
  fileEvent = id
  #endif
  
  -- XXX Tests for root as a regular file instead of dir?
  -- XXX Add symlink and hardlink tests
  -- XXX Add exception condition tests
  
  -------------------------------------------------------------------------------
  -- Dir tests
  -------------------------------------------------------------------------------
  
  createParent :: FilePath -> FilePath -> IO ()
  createParent file parent = do
      createDirectoryIfMissing True (takeDirectory (parent </> file))
  
  createDirWithParent :: FilePath -> FilePath -> IO ()
  createDirWithParent dir parent =
      when (not (null dir)) $ createDirectoryIfMissing True (parent </> dir)
  
  createDir :: FilePath -> FilePath -> IO ()
  createDir dir parent =
      when (not (null dir)) $ createDirectory (parent </> dir)
  
  -- | Create the dir along with its parent dir during the test. This is
  -- especially useful to detect a race in Linux case where the watch for a
  -- directory is added in event processing, so if the the child directory is
  -- created before the watch was installed then we may miss some events.
  dirCreateWithParent ::
      String -> (String -> [([Char], Event -> Bool)]) -> TestDesc
  dirCreateWithParent dir events =
      ( "dir created (" ++ dir ++ ")"
      , const (return ())
      , createDirWithParent dir
      , events dir
      )
  
  dirCreate :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc
  dirCreate dir events =
      ( "dir created (" ++ dir ++ ")"
      , createParent dir
      , createDir dir
      , events dir
      )
  
  dirDelete :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc
  dirDelete dir events =
        ( "dir deleted (" ++ dir ++ ")"
        , createDirWithParent dir
        , \fp -> removePathForcibly (fp </> dir)
        , events dir
        )
  
  dirMove ::
         String
      -> String
      -> (String -> String -> [(String, Event -> Bool)])
      -> TestDesc
  dirMove dir1 dir2 events =
        ( "dir moved (" ++ dir1 ++ " " ++ dir2 ++ ")"
        , createDirWithParent dir1
        , \fp -> renameDirectory (fp </> dir1) (fp </> dir2)
        , events dir1 dir2
        )
  
  rootDirMove ::
         String
      -> (String -> [(String, Event -> Bool)])
      -> TestDesc
  rootDirMove suffix events =
        ( "root dir moved" ++ "(" ++ suffix ++ ")"
        , const (return ())
        , \fp -> renameDirectory fp (fp <> suffix)
        , events ""
        )
  
  -------------------------------------------------------------------------------
  -- File tests
  -------------------------------------------------------------------------------
  
  createFileWithParent :: FilePath -> FilePath -> IO ()
  createFileWithParent file parent = do
      let filepath = parent </> file
      let dir = takeDirectory filepath
      putStrLn $ "createFileWithParent: file ["
          ++ file ++ "] dir [" ++ dir ++ "]"
      putStrLn $ "Ensuring dir: " ++ dir
      createDirectoryIfMissing True dir
      r <- doesDirectoryExist dir
      if r
      then do
          putStrLn $ "Ensured dir: " ++ dir
          when (not (null file)) $ do
              exists <- doesFileExist filepath
              if not exists
              then do
                  putStrLn $ "Creating file: " ++ (parent </> file)
                  openFile (parent </> file) WriteMode >>= hClose
                  putStrLn $ "Created file: " ++ (parent </> file)
              else error $ "File exists: " ++ filepath
      else error $ "Could not create dir: " ++ dir
  
  createFile :: FilePath -> FilePath -> IO ()
  createFile file parent =
      openFile (parent </> file) WriteMode >>= hClose
  
  fileCreate :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
  fileCreate file1 events =
      ( "File created (" ++ file1 ++ ")"
      , createParent file1
      , createFile file1
      , (file1, fileEvent Event.isCreated) : events file1
      )
  
  -- | See comments in dirCreateWithParent
  fileCreateWithParent ::
      String -> (String -> [(String, Event -> Bool)]) -> TestDesc
  fileCreateWithParent file1 events =
      ( "File created (" ++ file1 ++ ")"
      , const (return ())
      , createFileWithParent  file1
      , (file1, fileEvent Event.isCreated) : events file1
      )
  
  fileDelete :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
  fileDelete file1 events =
      ( "File deleted (" ++ file1 ++ ")"
      , createFileWithParent file1
      , \fp -> removeFile (fp </> file1)
      , events file1
      )
  
  fileModify :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
  fileModify file1 events =
      ( "File modified (" ++ file1 ++ ")"
      , createFileWithParent file1
      , \fp -> writeFile (fp </> file1) "Test Data"
      , (file1, fileEvent Event.isModified) : events file1
      )
  
  fileMove ::
         String
      -> String
      -> (String -> String -> [(String, Event -> Bool)])
      -> TestDesc
  fileMove file1 file2 events =
      ( "File moved (" ++ file1 ++ " " ++ file2 ++ ")"
      , createFileWithParent file1
      , \fp -> renamePath (fp </> file1) (fp </> file2)
      ,     (file1, fileEvent Event.isMoved)
          : (file2, fileEvent Event.isMoved)
          : events file1 file2
      )
  
  rootFileMove :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
  rootFileMove suffix events =
      ( "File moved (" ++ suffix ++ ")"
      , const (return ())
      , \fp -> renamePath fp (fp <> suffix)
      , events ""
      )
  
  -------------------------------------------------------------------------------
  -- Common test bundles
  -------------------------------------------------------------------------------
  
  withParent :: [Char] -> [Char] -> [Char]
  withParent parent file = if null parent then file else parent </> file
  
  testsWithParent :: String -> [TestDesc]
  testsWithParent p =
      [ dirCreate
          (withParent p "dir") (\dir -> [(dir, dirEvent Event.isCreated)])
      , dirDelete
          (withParent p "dir") (\dir -> [(dir, dirEvent Event.isDeleted)])
      , dirMove
          (withParent p "dir1")
          (withParent p "dir2")
          (\dir1 dir2 ->
              [ (dir1, dirEvent Event.isMoved)
              , (dir2, dirEvent Event.isMoved)
              ]
          )
      , fileCreate (withParent p "file1") (const [])
      , fileDelete
          (withParent p "file1")
          (\file -> [(file, fileEvent Event.isDeleted)])
      , fileModify (withParent p "file1") (const [])
      , fileMove (withParent p "file1") (withParent p "file2") (\_ _ -> [])
      ]
  
  commonTests :: [TestDesc]
  commonTests = testsWithParent ""
  
  commonRecTests :: [TestDesc]
  commonRecTests = testsWithParent "subdir"
  
  -------------------------------------------------------------------------------
  -- Running tests
  -------------------------------------------------------------------------------
  
  runTests ::
         String
      -> String
      -> EventWatcher
      -> WatchRootType
      -> [TestDesc]
      -> IO ()
  runTests modName watchType watcher rootType tests = do
      hSetBuffering stdout NoBuffering
      hspec
          $ describe modName
          $ describe watchType
          $ do
              let checker = checkEvents watcher
              describe ("Root type " ++ show rootType)
                      $ mapM_ (driver checker rootType) tests
  