{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE  PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
module Main (main) where

import           Control.Concurrent.EQueue
import           Control.Concurrent.MVar
import           Control.Monad
import           Control.Monad.Trans
import           Control.Monad.Ref
import qualified Control.Monad.Catch as E
import qualified Control.Time as Time
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import           Data.Dependent.Sum (DSum ((:=>)))
import           Data.Fixed
import           Data.Functor.Identity
import           Data.Int
import           Data.List (sort, group)
import qualified Data.ListTrie.Patricia.Map as LT
import           Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Time.Clock (getCurrentTime, diffUTCTime)
import           Foreign.Storable
import           Reflex
import           Reflex.Filesystem.DirTree
import           Reflex.Host.Class
import           System.Directory (removeDirectoryRecursive, createDirectory
                                  ,createDirectoryIfMissing, removeFile
                                  ,renameDirectory, setCurrentDirectory, getCurrentDirectory)
import           Reflex.Filesystem.Internal
import           System.FilePath ((</>))
import qualified System.FilePath as FP
import qualified System.FSNotify as FSN
import           System.IO.MMap
import           System.Posix.Temp (mkdtemp)
import           Test.Tasty
import           Test.Tasty.HUnit

-- | Uses a watch on the specified directory and writing to a file in it
--   to observe the local inotify latency.
--   Then wait the specified multiple of that observed time.
inotifyLatencyWait :: MonadIO m => Rational -> FilePath -> m ()
inotifyLatencyWait m f = liftIO $ do
  mvW <- newEmptyMVar
  st <- getCurrentTime
  let markFile = f </> "mark"
  FSN.withManager $ \wm -> do
    e <- FSN.watchDir wm f (const True) (const (void $ putMVar mvW ()))
    BS.writeFile markFile mempty
    void $ takeMVar mvW
    e
    removeFile markFile
  et <- getCurrentTime
  Time.delay (fromRational $ m*(toRational $ et `diffUTCTime` st)::Pico)

-- | Writes a DirTree out to te filesystem.
writeDirTree :: FilePath -> DirTree BS.ByteString -> IO ()
writeDirTree bDir dt = do
  createDirectoryIfMissing True bDir
  forM_ (LT.toList dt) $ \(p, c) -> do
    let subPath = FP.joinPath . fmap T.unpack $ p
    let fullPath = bDir </> subPath
    createDirectoryIfMissing True (FP.takeDirectory $ fullPath)
    BS.writeFile fullPath c

bigExampleTree :: DirTree BS.ByteString
bigExampleTree = LT.fromList [(["a"],"#")
                             ,(["b","1"],"##5")
                             ,(["b","2"],"##2")
                             ,(["b","3"],"##3")
                             ,(["c","d", "e"],"##4")
                             ,(["o","n","e"], TE.encodeUtf8 "o n e")
                             ,(["t","w","o"], TE.encodeUtf8 "t w o")
                             ,(["t","w","2"], TE.encodeUtf8 "t w 2")
                             ,(["one"], TE.encodeUtf8 "one")
                             ,(["two"], TE.encodeUtf8 "two")
                             ]

main :: IO ()
main =
  defaultMain .
      testGroup "reflex-inotify" $
      [ readAsUpdateTests
      , readTreeTests
      , e2eTests
      , watchDirTests
      , followDirTests
      , dirSourceTests
      -- Mostly to get coverage
      , testCase "DataUpdate Order" $ do
          assertBool "DataMod before PathDel" ((DataMod BS.empty) < PathDel)
          assertBool "DataMod before PathDel" ((DataMod BS.empty) <= PathDel)
          assertBool "DataMod before PathDel" (PathDel > (DataMod BS.empty))
          assertBool "DataMod before PathDel" (PathDel >= (DataMod BS.empty))
          assertEqual "DataMod LT PathDel" (compare (DataMod BS.empty) PathDel) LT
      -- Just for coverage
      , testCase "Show DataUpdate" $ do
          assertEqual "Show DataUpdate shows expected" (show (PathDel::DataUpdate BS.ByteString)) "PathDel"
      ]

readAsUpdateTests :: TestTree
readAsUpdateTests =
  testGroup "readAsUpdate" $
  [ testCase "non-existant file" .
      E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \tDir -> do
        r <- readAsUpdate tDir ("a")
        r' <- readAsUpdate tDir (tDir </> "a")
        r' @=? r
        [(["a"], PathDel)] @=? r
  , testCase "reads empty file" .
      E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \tDir -> do
        let ef = tDir </> "empty"
        BS.writeFile ef mempty
        r <- readAsUpdate tDir ef
        [(["empty"], DataMod mempty)] @=? r
  , testCase "reads file contents" .
      E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \tDir -> do
        let ef = tDir </> "full"
        let fconts = TE.encodeUtf8 "This is test file contents."
        BS.writeFile ef fconts
        r <- readAsUpdate tDir ef
        [(["full"], DataMod fconts)] @=? r
  ]

readTreeTests :: TestTree
readTreeTests =
  testGroup "readTree" $ (map
    (\(tName, bDir, sDir, t, dt) ->
      testCase tName .
        E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \tDir -> do
        let wDir = tDir </> bDir
        writeDirTree wDir dt
        r <- readTree wDir sDir
        (sort . LT.toList . fmap DataMod . t $ dt) @=? (filter ((PathDel /=) . snd) $ sort r)
      ) $
    [ ( "read an empty dir", "empty", "", id, mempty)
    , ( "read a dir with a file",  "oneFile", "", id
      , LT.singleton ["one"] . TE.encodeUtf8 $ "one")
    , ( "read a file several dirs down", "deepFile", "", id
      , LT.singleton ["o","n","e"] . TE.encodeUtf8 $ "one")
    , ( "read several files", "multiFile", "", id, LT.fromList
        [ (["o","n","e"], TE.encodeUtf8 "o n e")
        , (["t","w","o"], TE.encodeUtf8 "t w o")
        , (["t","w","2"], TE.encodeUtf8 "t w 2")
        , (["one"], TE.encodeUtf8 "one")
        , (["two"], TE.encodeUtf8 "two")
        ]
      )
    , ( "read an empty dir (deep)", "emptyS", "deeper", LT.lookupPrefix ["deeper"], mempty)
    , ( "read a dir with a file (deep)",  "oneFileS", "deeper", LT.lookupPrefix ["deeper"]
      , LT.singleton ["deeper", "one"] . TE.encodeUtf8 $ "one")
    , ( "don't read a files (deep)", "deepFile", "deeper", LT.lookupPrefix ["deeper"]
      , LT.fromList [(["o","n","e"], TE.encodeUtf8 $ "one"), (["two"], TE.encodeUtf8 "two")])
    , ( "read a file several dirs down (deep)", "deepFile", "deeper", LT.lookupPrefix ["deeper"]
      , LT.singleton ["deeper", "o","n","e"] . TE.encodeUtf8 $ "one")
    , ( "read several files (deep)", "multiFile", "deeper", LT.lookupPrefix ["deeper"], LT.fromList
        [ (["deeper", "o","n","e"], TE.encodeUtf8 "o n e")
        , (["deeper", "t","w","o"], TE.encodeUtf8 "t w o")
        , (["deeper", "t","w","2"], TE.encodeUtf8 "t w 2")
        , (["deeper", "one"], TE.encodeUtf8 "one")
        , (["deeper", "two"], TE.encodeUtf8 "two")
        ]
      )
    ]) ++
    [ testCase "read missing dir" .
        E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \tDir -> do
          r <- readTree tDir "subdir"
          [(["subdir"], PathDel)] @=? r
    ]

e2eTests :: TestTree
e2eTests =
  testGroup "e2e" . map
    (\(tName, ev, er) ->
      testCase tName .
        E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \tDir -> do
          let wDir = tDir </> tName
          writeDirTree wDir bigExampleTree
          ar <- e2e wDir ev
          er @=? (sort ar)
      ) $
    [ ("Added existing file", FSN.Added "a" undefined undefined
      ,mkRes $ LT.lookupPrefix ["a"] bigExampleTree)
    , ("Added deep file", FSN.Added "b/1" undefined undefined
      ,mkRes $ LT.lookupPrefix ["b","1"] bigExampleTree)
    , ("Added existing dir", FSN.Added "b" undefined undefined
      ,mkRes $ LT.lookupPrefix ["b"] bigExampleTree)
    , ("Added fake file", FSN.Added "z" undefined undefined
      ,[(["z"], PathDel)])
    , ("Modded existing file", FSN.Modified "a" undefined undefined
      ,mkRes $ LT.lookupPrefix ["a"] bigExampleTree)
    , ("Modded deep file", FSN.Modified "b/1" undefined undefined
      ,mkRes $ LT.lookupPrefix ["b","1"] bigExampleTree)
    , ("Modded fake file", FSN.Modified "z" undefined undefined
      ,[(["z"], PathDel)])
    , ("Removed file", FSN.Removed "a" undefined undefined
      ,[(["a"], PathDel)])
    , ("Removed dir", FSN.Removed "b" undefined undefined
      ,[(["b"], PathDel)])
    , ("Removed fake", FSN.Removed "z" undefined undefined
      ,[(["z"], PathDel)])
    , ("Unknown rescans", FSN.Unknown undefined undefined undefined
      ,mkRes bigExampleTree)
    ]
  where
    mkRes = sort . LT.toList . fmap DataMod

watchDirTests :: TestTree
watchDirTests =
  testGroup "watchDir"
  [ testWatch "No events on inaction" $ \_ ->
      [(return (), [])]
  , testWatch "memptyFile event" $ \wDir ->
    [ ( writeFile (wDir </> "memptyFile") ""
      , [(["memptyFile"], DataMod "")])]
  , testWatch "simpleFile with actual content" $ \wDir ->
    [ ( writeFile (wDir </> "simpleFile") "Nonempty"
      , [(["simpleFile"], DataMod "Nonempty")])]
  , testWatch "Empty directory creation has no event" $ \wDir ->
      [ (createDirectory (wDir </> "subDir"), [])]
  , testWatch "File creation in new subdir causes event" $ \wDir ->
    [ ( createDirectory (wDir </> "subDir") >>
        writeFile (wDir </> "subDir" </> "subFile") "#"
      , [(["subDir", "subFile"], DataMod "#")])]
  , testWatch "memptyFile deletion" $ \wDir ->
    [ ( writeFile (wDir </> "memptyFile") ""
      , [(["memptyFile"], DataMod "")])
    , ( removeFile (wDir </> "memptyFile")
      , [(["memptyFile"], PathDel)])
    ]
  , testWatch "Empty directory rename" $ \wDir ->
    [ ( createDirectory (wDir </> "subDir") >>
        renameDirectory (wDir </> "subDir") (wDir </> "otherDir")
      , [(["subDir"], PathDel)])]
  , testWatch "subFile removal" $ \wDir ->
    [ ( createDirectory (wDir </> "subDir") >>
        writeFile (wDir </> "subDir" </> "subFile") "#"
      , [(["subDir", "subFile"], DataMod "#")])
    , ( removeFile (wDir </> "subDir" </> "subFile")
      , [(["subDir", "subFile"], PathDel)])]
  , testWatch "subDir move with file recreates" $ \wDir ->
    [ ( createDirectory (wDir </> "subDir"), [])
    , ( writeFile (wDir </> "subDir" </> "subFile") "#"
      , [(["subDir", "subFile"], DataMod "#")])
    , ( renameDirectory (wDir </> "subDir") (wDir </> "otherDir")
      , [(["subDir"], PathDel)
        ,(["otherDir", "subFile"], DataMod "#")])
    ]
  , testWatch "write into moved subDir" $ \wDir ->
    [ ( createDirectory (wDir </> "subDir"), [])
    , ( renameDirectory (wDir </> "subDir") (wDir </> "otherDir")
      , [(["subDir"], PathDel)])
    , ( writeFile (wDir </> "otherDir" </> "subFile") "#"
      , [(["otherDir", "subFile"], DataMod "#")])
    ]
  , testWatch "Fast write into moved subDir" $ \wDir ->
    [ ( createDirectory (wDir </> "subDir") >>
        renameDirectory (wDir </> "subDir") (wDir </> "otherDir")
      , [(["subDir"], PathDel)])
    , ( writeFile (wDir </> "otherDir" </> "subFile") "#"
      , [(["otherDir", "subFile"], DataMod "#")])
    ]
  , testWatch "mmap writes" $ \wDir ->
    [ ( mmapWithFilePtr (wDir </> "testFile") ReadWriteEx (Just (0, 8)) $
                            \(ptr, 8) -> pokeByteOff ptr 0 (0::Int64)
      , [(["testFile"], DataMod . BL.toStrict . BB.toLazyByteString . BB.int64BE $ 0)])
    ]
  , testCase "Correct relative path watching" $ do
      -- There can only be one of these tests!
      -- Unless we have a global lock on what our working dir is.
      sDir <- getCurrentDirectory
      E.bracket (mkdtemp "/tmp/")
        (\d -> setCurrentDirectory sDir >> removeDirectoryRecursive d) $ \bDir -> do
        setCurrentDirectory bDir
        let wDir = "work"
        let iDir = bDir </> "watch"
        mapM_ createDirectory [wDir, iDir]
        let cases =
              [ ( writeFile (wDir </> "memptyFile") ""
                , [(["memptyFile"], DataMod "")])
              , ( removeFile (wDir </> "memptyFile")
                , [(["memptyFile"], PathDel)])
              , ( writeFile (wDir </> "simpleFile") "Nonempty"
                , [(["simpleFile"], DataMod "Nonempty")])
              , (createDirectory (wDir </> "subDir"), [])
              , (writeFile (wDir </> "subDir" </> "subFile") "#"
                , [(["subDir", "subFile"], DataMod "#")])
              , ( removeFile (wDir </> "subDir" </> "subFile")
                , [(["subDir", "subFile"], PathDel)])
              , (renameDirectory (wDir </> "subDir") (wDir </> "otherDir")
                , [(["subDir"], PathDel)])
              , ( writeFile (wDir </> "otherDir" </> "subFile") "#"
                , [(["otherDir", "subFile"], DataMod "#")])
              -- ^  !!! This triggers a bug in fsnotify where renaming directories
              --    fails to update the path to the watch.
              , ( renameDirectory (wDir </> "otherDir") (wDir </> "subDir")
                , [(["otherDir"], PathDel)
                  ,(["subDir", "subFile"], DataMod "#")])
              ]
        runSpiderHost $ do
          eq <- newSTMEQueue
          fsE <- (runHostFrame $ watchDir eq wDir) >>= subscribeEvent
          let doStep act = do
                -- Trigger the causal action.
                void $ liftIO act
                -- we wait for the event to show up.
                inotifyLatencyWait 2 iDir
                es <- waitEQ eq ReturnImmediate
                (sort . map head . group . fromMaybe []) <$>
                  (fireEventsAndRead es (readEvent fsE >>= sequence))
          forM_ (cases++[(return (), [])]) $ \(ioAct, e) ->
            doStep ioAct >>= (liftIO . ((sort e) @=?))
          fireEventsAndRead [] . void $ readEvent fsE
  ]
  where
    testWatch :: String -> (String -> [(IO (), [([T.Text], DataUpdate BS.ByteString)])]) -> TestTree
    testWatch testName eventCreator = testCase testName .
      E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \bDir -> do
        let wDir = bDir </> "work"
        let iDir = bDir </> "watch"
        mapM_ createDirectory [wDir, iDir]
        runSpiderHost $ do
          eq <- newSTMEQueue
          fsE <- (runHostFrame $ watchDir eq wDir) >>= subscribeEvent
          let doStep act = do
                -- Trigger the causal action.
                void $ liftIO act
                -- we wait for the event to show up.
                inotifyLatencyWait 2 iDir
                es <- waitEQ eq ReturnImmediate
                (sort . map head . group . fromMaybe []) <$>
                  (fireEventsAndRead es (readEvent fsE >>= sequence))
          forM_ ((eventCreator wDir)++[(return (), [])]) $ \(ioAct, e) ->
            doStep ioAct >>= (liftIO . ((sort e) @=?))
          fireEventsAndRead [] . void $ readEvent fsE

decodeDynDirTree :: (Reflex t, MonadSample t m) => DynDirTree t a -> m (DirTree a)
decodeDynDirTree dt = sample (current dt) >>= mapM (sample . current)

followDirTests :: TestTree
followDirTests = testGroup "followDir"
  [ testFDir "No events starts correct (mempty)" [] [(Nothing, mempty)]
  , let baseData = [(["a"], "#"), (["b", "c"], "##")]
    in testFDir "No events starts correct (nontrivial)"
         (map (fmap DataMod) baseData) [(Nothing, baseData)]
  , testGroup "Single Update"
    [ testFDir "Addative" []
                          [ (jS (["a"],DataMod "#"), [(["a"],"#")])
                          , (jS (["b","c"],DataMod "##"), [(["a"],"#"),(["b","c"],"##")])
                          ]
    , testFDir "Replace" [ (["a"],DataMod "#"),(["b","c"],DataMod "##") ]
                         [ (jS (["a"], DataMod "1"), [ (["a"],"1")
                                                     , (["b","c"],"##") ])
                         , (jS (["b"], DataMod "2"), [ (["a"],"1")
                                                     , (["b"],"2")
                                                     , (["b","c"],"##") ])
                         , (jS (["b", "c"], DataMod "3"), [ (["a"],"1")
                                                          , (["b"],"2")
                                                          , (["b","c"],"3") ])
                         ]
    , testFDir "Subtractive" [ (["a"],DataMod "#"),(["b","c"],DataMod "##") ]
                             [ (jS (["a"],PathDel), [(["b","c"],"##")])
                             , (jS (["b","c"],PathDel), mempty)
                             ]
    , testFDir "Path deletion" [(["a"],DataMod "#")
                               ,(["b","1"],DataMod "##1")
                               ,(["b","2"],DataMod "##2")
                               ,(["b","3"],DataMod "##3")
                               ]
                               [ (jS (["b"], PathDel), [(["a"],"#")]) ]
    , testFDir "Mutative" [(["a"],DataMod "#")
                          ,(["b","1"],DataMod "##1")
                          ,(["b","2"],DataMod "##2")
                          ,(["b","3"],DataMod "##3")
                          ]
                          [ (Nothing, [(["a"],"#")
                                      ,(["b","1"],"##1")
                                      ,(["b","2"],"##2")
                                      ,(["b","3"],"##3")])
                          , (jS (["c","d", "e"], DataMod "##4"), [(["a"],"#")
                                                                 ,(["b","1"],"##1")
                                                                 ,(["b","2"],"##2")
                                                                 ,(["b","3"],"##3")
                                                                 ,(["c","d", "e"],"##4")])
                          , (jS (["b", "1"], PathDel), [(["a"],"#")
                                                       ,(["b","2"],"##2")
                                                       ,(["b","3"],"##3")
                                                       ,(["c","d", "e"],"##4")])
                          , (jS (["b", "1"], DataMod "##5"), [(["a"],"#")
                                                             ,(["b","1"],"##5")
                                                             ,(["b","2"],"##2")
                                                             ,(["b","3"],"##3")
                                                             ,(["c","d", "e"],"##4")])
                          , (jS (["b"], PathDel),  [(["a"],"#"), (["c","d", "e"],"##4")])
                          ]
    ]
  , testGroup "Multi Update"
    [ testFDir "Addative" []
                          [ (jFL [(["a"],DataMod "#"), (["b","c"],DataMod "##")]
                            ,[(["a"],"#"),(["b","c"],"##")])
                          ]
    , testFDir "Replace" [ (["a"],DataMod "#"),(["b","c"],DataMod "##") ]
                         [ (jFL [ (["a"], DataMod "1")
                                , (["b"], DataMod "2")
                                , (["b", "c"], DataMod "3")
                                ], [ (["a"],"1")
                                   , (["b"],"2")
                                   , (["b","c"],"3") ])
                         ]
    , testFDir "Subtractive" [ (["a"],DataMod "#"),(["b","c"],DataMod "##") ]
                             [ (jFL [ (["a"],PathDel)
                                    , (["b","c"],PathDel)
                                    ]
                               , mempty)
                             ]
    , testFDir "Mutative" [(["a"],DataMod "#")
                          ,(["b","1"],DataMod "##1")
                          ,(["b","2"],DataMod "##2")
                          ,(["b","3"],DataMod "##3")
                          ]
                          [ (jFL [ (["c","d", "e"], DataMod "##4")
                                 , (["b", "1"], PathDel)
                                 , (["b", "1"], DataMod "##5")
                                 , (["b"], PathDel)
                                 ]
                             , [(["a"],"#"), (["c","d", "e"],"##4")])
                          ]
    ]
  ]
  where
    jS :: ([T.Text], DataUpdate BS.ByteString) -> Maybe [([T.Text], DataUpdate BS.ByteString)]
    jS = Just . pure
    jFL :: [([T.Text], DataUpdate BS.ByteString)] -> Maybe [([T.Text], DataUpdate BS.ByteString)]
    jFL = Just
    testFDir :: String -> [([T.Text], DataUpdate BS.ByteString)]
            -> [(Maybe [([T.Text], DataUpdate BS.ByteString)], [([T.Text], BS.ByteString)])] -> TestTree
    testFDir nm initial updates = testCase nm $ do
      runSpiderHost $ do
        (re, rmt) <- newEventWithTriggerRef
        rd <- runHostFrame $ followDir initial re
        mrt <- readRef rmt
        rt <- maybe (liftIO $ assertFailure "event not used") return mrt
        let doStep ev = do
              -- Trigger the causal action.
              fromMaybe (return ()) .
                fmap (\v -> fireEventsAndRead [rt :=> (Identity v)] (return ())) $ ev
              decodeDynDirTree rd
        forM_ updates $ \(ev, r) ->
          doStep ev >>= (liftIO . ((LT.fromList r) @=?))

dirSourceTests :: TestTree
dirSourceTests = testGroup "dirSource"
  [ testWDir "No actions remains empty" mempty $ \_ ->
      [(return (), mempty)]
  , testWDir "No actions doesn't change" (LT.singleton ["a"] (TE.encodeUtf8 "Test")) $ \_ ->
      [(return (), LT.singleton ["a"] (TE.encodeUtf8 "Test"))]
  , testWDir "Fills DirTree" mempty $ \wDir ->
      [(writeDirTree wDir bigExampleTree, bigExampleTree)]
  , testWDir "Reads full tree" bigExampleTree $ \_ ->
      [(return (), bigExampleTree)]
  , testCase "Initially samples correct" .
    E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \bDir -> do
      let wDir = bDir </> "work"
      let iDir = bDir </> "watch"
      mapM_ createDirectory [wDir, iDir]
      writeDirTree wDir bigExampleTree
      runSpiderHost $ do
        eq <- newSTMEQueue
        rd <- (runHostFrame $ dirSource eq wDir)
        (liftIO . (bigExampleTree @=?)) =<< decodeDynDirTree rd
  ]
  where
    testWDir :: String -> DirTree BS.ByteString
             -> (String -> [(IO (), DirTree BS.ByteString)])
             -> TestTree
    testWDir nm initial eventCreator = testCase nm .
      E.bracket (mkdtemp "/tmp/") (removeDirectoryRecursive) $ \bDir -> do
        let wDir = bDir </> "work"
        let iDir = bDir </> "watch"
        mapM_ createDirectory [wDir, iDir]
        writeDirTree wDir initial
        runSpiderHost $ do
          eq <- newSTMEQueue
          rd <- (runHostFrame $ dirSource eq wDir)
          let doStep act = do
                -- Trigger the causal action.
                void $ liftIO act
                -- we wait for the event to show up.
                inotifyLatencyWait 2 iDir
                es <- waitEQ eq ReturnImmediate
                fireEventsAndRead es $ return ()
                decodeDynDirTree rd
          forM_ (eventCreator wDir) $ \(ioAct, e) ->
            doStep ioAct >>= (liftIO . (e @=?))