-- | Wraps inner 'GitImpl' and caches read operations. Cache is invalidated
-- when repo is pushed to. Cache is also evicted every two hours for each repo
module Git.Cached
    ( make
    ) where

import ClassyPrelude

import qualified Git.Class as Git
import qualified Log

import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Git.Class (GitImpl (GitImpl))
import System.OsPath (OsPath)

data RepoCache = RepoCache
    { branches :: !(Maybe [Text])
    , objects :: !(Maybe (HashMap OsPath Git.GitObject))
    , lastCommits :: !(Maybe [Git.HistoryItem])
    , evicter :: !(MVar ThreadId)
    }

type GlobalCache = HashMap OsPath (MVar RepoCache)

make
    :: Int
    -- ^ Delay in seconds until cache is cleared for repo
    -> GitImpl
    -> IO GitImpl
make clearDelay inner = do
    cacheVar <- newMVar (mempty :: GlobalCache)
    let clearCache repoPath = do
            mbRepoCache <-
                modifyMVar cacheVar $
                    pure . \cache -> case lookup repoPath cache of
                        Nothing -> (cache, Nothing)
                        Just var -> do
                            (updateMap (const Nothing) repoPath cache, Just var)
            case mbRepoCache of
                Nothing -> pure ()
                Just repoCacheVar -> do
                    RepoCache{evicter} <- readMVar repoCacheVar
                    tid <- tryTakeMVar evicter
                    mapM_ killThread tid

    let getRepoCacheVar repoPath =
            readMVar cacheVar <&> lookup repoPath >>= \case
                Just var -> pure var
                Nothing -> modifyMVar cacheVar $ \cache -> do
                    case lookup repoPath cache of
                        -- by the time we obtain the lock, other thread might
                        -- have created it too
                        Just var -> pure (cache, var)
                        -- create if doesn't exist
                        Nothing -> do
                            Log.trace $ "Git.Cached: cache miss for " <> tshow repoPath
                            -- Invariant: no other piece of code writes to this mvar
                            evicterVar <- newEmptyMVar
                            var <- newMVar $ RepoCache Nothing Nothing Nothing evicterVar
                            let cache' = insertMap repoPath var cache
                            -- clean repo cache every two hours
                            evicterTid <- forkIO $ do
                                threadDelay $ clearDelay * 1_000_000
                                Log.trace $ "Git.Cached: time eviction for " <> tshow repoPath
                                -- to prevent this thread killing itself, remove its threadId
                                -- (it will die soon anyway)
                                _ <- tryTakeMVar evicterVar
                                clearCache repoPath
                            putMVar evicterVar evicterTid
                            pure (cache', var)

    let checksCache
            :: (RepoCache -> Maybe a)
            -> (a -> RepoCache -> RepoCache)
            -> (OsPath -> IO a)
            -> OsPath
            -> IO a
        checksCache field setter fallback repoPath = do
            repoCacheVar <- getRepoCacheVar repoPath
            readMVar repoCacheVar <&> field >>= \case
                Just val -> pure val
                Nothing -> modifyMVar repoCacheVar $ \repoCache ->
                    case field repoCache of
                        -- in case it appeared while obtaining the lock
                        Just val -> pure (repoCache, val)
                        Nothing -> do
                            val <- fallback repoPath
                            let repoCache' = setter val repoCache
                            pure (repoCache', val)
    let checksCache2
            :: Hashable a
            => (RepoCache -> Maybe (HashMap a b))
            -> (HashMap a b -> RepoCache -> RepoCache)
            -> (OsPath -> a -> IO b)
            -> OsPath
            -> a
            -> IO b
        checksCache2 field setter fallback repoPath arg = do
            repoCacheVar <- getRepoCacheVar repoPath
            -- unhappy path
            let inserts = modifyMVar repoCacheVar $ \repoCache ->
                    case field repoCache of
                        Just hashmap -> case lookup arg hashmap of
                            Just val -> pure (repoCache, val)
                            Nothing -> do
                                val <- fallback repoPath arg
                                let hashmap' = insertMap arg val hashmap
                                let repoCache' = setter hashmap' repoCache
                                pure (repoCache', val)
                        Nothing -> do
                            val <- fallback repoPath arg
                            let hashmap = singletonMap arg val
                            let repoCache' = setter hashmap repoCache
                            pure (repoCache', val)
            -- try reading without locking, go to unhappy path if not found
            readMVar repoCacheVar <&> field >>= \case
                Just hashmap -> case lookup arg hashmap of
                    Just val -> pure val -- happy path
                    Nothing -> inserts
                Nothing -> inserts

    pure
        GitImpl
            { Git.createRepo = Git.createRepo inner
            , Git.renameRepo = Git.renameRepo inner
            , Git.getBranches =
                checksCache branches (\x c -> c{branches = Just x}) (Git.getBranches inner)
            , Git.getObject =
                checksCache2 objects (\x c -> c{objects = Just x}) (Git.getObject inner)
            , Git.getLastCommits =
                checksCache
                    lastCommits
                    (\x c -> c{lastCommits = Just x})
                    (Git.getLastCommits inner)
            , Git.advertiseRefsUpload = Git.advertiseRefsUpload inner
            , Git.advertiseRefsReceive = Git.advertiseRefsReceive inner
            , Git.uploadPack = Git.uploadPack inner
            , Git.receivePack = \repoPath arg -> do
                Log.trace $ "Git.Cached: write eviction for " <> tshow repoPath
                liftIO $ clearCache repoPath
                Git.receivePack inner repoPath arg
            }