{-# OPTIONS -Wall #-}
{-# LANGUAGE StandaloneDeriving, LambdaCase, BlockArguments #-}
{-# LANGUAGE DeriveGeneric, DerivingStrategies, GeneralizedNewtypeDeriving, DeriveAnyClass #-}
module Main (main) where

import           Control.Concurrent
import           Control.Concurrent.Async
import           Control.Exception (catch, throwIO, evaluate)
import           Control.Lens
import           Crypto.Hash.SHA256 (hashlazy)
import           Data.Aeson
import           Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import           Data.Foldable
import qualified Data.HexString as Hex
import           Data.IORef
import           Data.Map (Map)
import           Data.Time.Clock (UTCTime)
import           GHC.Generics (Generic)
import           System.Directory
import           System.Directory.PathWalk
import           System.FilePath
import           System.IO.Error
import           Text.Printf (printf)

newtype SHA256 = SHA256 { sha256bs :: BS.ByteString }
    deriving stock (Generic, Show, Eq)

instance FromJSON SHA256 where
    parseJSON = fmap (SHA256 . Hex.toBytes) . parseJSON

instance ToJSON SHA256 where
    toJSON = toJSON . Hex.fromBytes . sha256bs

data FileData = FileData
    { fileMTime :: !UTCTime
    , fileHash :: !SHA256
    } deriving stock (Generic, Show)
    deriving anyclass (FromJSON, ToJSON)

newtype Database = Database
    { _dbFiles :: Map FilePath FileData
    } deriving stock (Show, Generic)
    deriving anyclass (FromJSON, ToJSON)

dbFiles :: Iso' Database (Map FilePath FileData)
dbFiles = iso _dbFiles Database

emptyDb :: Database
emptyDb = Database mempty

dbDir :: FilePath
dbDir = ".db"

dbPath :: FilePath
dbPath = dbDir </> "files.json"

readDb :: FromJSON a => FilePath -> IO a -> IO a
readDb path missingFile =
    (Right <$> BSL.readFile path)
    `catch`
    (\exc -> if isDoesNotExistError exc then Left <$> missingFile else throwIO exc)
    <&> _Right %~ eitherDecode'
    >>= _Right %%~ \case
        Left err -> fail $ "Failed to parse " <> path <> ": " <> err
        Right x -> pure x
    <&> either id id

logIfSlow :: String -> IO a -> IO a
logIfSlow msg act =
    withAsync do
        threadDelay 500000
        putStrLn msg
    (const act)

getHash :: FilePath -> IO SHA256
getHash path =
    logIfSlow ("computing hash of " <> path) $
    BSL.readFile path
    <&> hashlazy
    <&> SHA256
    >>= evaluate

handle :: IORef Database -> FilePath -> IO ()
handle dbRef path =
    do
        db <- readIORef dbRef
        mtime <- getModificationTime path
        db & dbFiles . at path %%~ changeEntry mtime
            >>= writeIORef dbRef
    where
        changeEntry mtime Nothing =
            getHash path
            <&> \hash -> Just FileData { fileMTime = mtime, fileHash = hash }
        changeEntry mtime (Just fileData)
            | mtime == fileMTime fileData = pure (Just fileData)
            | otherwise =
                  do
                      hash <- getHash path
                      newMTime <-
                          if hash == fileHash fileData then do
                          putStrLn $ "restoring mtime of " <> path
                          setModificationTime path (fileMTime fileData)
                          pure $ fileMTime fileData
                          else
                          pure mtime
                      pure $ Just FileData { fileMTime = newMTime, fileHash = hash }

reservedBlacklist :: [FilePath]
reservedBlacklist = [".git"]

main :: IO ()
main =
    do
        dbRef <- readDb dbPath (pure emptyDb) >>= newIORef
        blacklist <- readDb (dbDir </> "blacklist.json") (pure [])
        let fullBlacklist = blacklist <> reservedBlacklist
        pathWalkInterruptible "." $ \path _dirs files ->
            logIfSlow (printf "Walking %s with %s files" path (length files)) $
            if path == dbDir || takeFileName path `elem` fullBlacklist
            then pure StopRecursing
            else do
                for_ files $ \file ->
                    handle dbRef (path </> file)
                pure Continue
        createDirectoryIfMissing True dbDir
        readIORef dbRef
            <&> encodePretty
            >>= BSL.writeFile dbPath