{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Store
  ( withStore,
    listDirectory,
    readFile,
  )
where

import Control.Arrow (first)
import Control.Monad.Catch
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader (ReaderT)
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.List (isPrefixOf, sort)
import Data.Text qualified as T
import Git
import Git.Libgit2 (LgRepo, lgFactory)
import System.FilePath
import Prelude hiding (readFile)

withStore ::
  (MonadMask m, MonadUnliftIO m) =>
  FilePath ->
  ReaderT LgRepo m a ->
  m a
withStore = withRepository lgFactory

listDirectory ::
  MonadGit r m =>
  CommitOid r ->
  FilePath ->
  m [FilePath]
listDirectory cid dir' = do
  let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
      n = length (splitPath dir)
  tid <- (.commitTree) <$> lookupCommit cid
  tree <- lookupTree tid
  sort
    . map (makeRelative dir)
    . filter ((== n + 1) . length . splitPath)
    . filter (isPrefixOf (addTrailingPathSeparator dir))
    . map fst
    . map
      ( \e ->
          case snd e of
            BlobEntry _ _ -> e
            CommitEntry _ -> error "XXX commit entry"
            TreeEntry _ -> first addTrailingPathSeparator e
      )
    . map (first (("/" <>) . B.toString))
    <$> listTreeEntries tree

data DoesNotExist = DoesNotExist String FilePath
  deriving (Show)

instance Exception DoesNotExist

data InappropriateType = InappropriateType String FilePath
  deriving (Show)

instance Exception InappropriateType

class Readable a where
  readFile :: MonadGit r m => CommitOid r -> FilePath -> m a

instance Readable T.Text where
  readFile = readFile' catBlobUtf8

instance Readable B.ByteString where
  readFile = readFile' catBlob

instance Readable LB.ByteString where
  readFile = readFile' catBlobLazy

readFile' ::
  MonadGit r m =>
  (BlobOid r -> m a) ->
  CommitOid r ->
  FilePath ->
  m a
readFile' cat cid fp = do
  tid <- (.commitTree) <$> lookupCommit cid
  tree <- lookupTree tid
  maybe
    (throwM (DoesNotExist "readFile" fp))
    ( \e ->
        case e of
          BlobEntry bid _ -> cat bid
          CommitEntry _ -> error "XXX commit entry"
          TreeEntry _ -> throwM (InappropriateType "readFile" fp)
    )
    =<< treeEntry tree (B.fromString fp)