path: root/src/Store/Store.hs

module Store.Store
  ( StoreM,
    withStore,
    withCommit,
    listFiles,
    listAllFiles,
    readFile,
    writeFile,
    deleteFile,
    commit,
  )
where

import Bindings.Libgit2 qualified as B
import Control.Arrow (first)
import Control.Exception (Exception, finally, throw)
import Control.Monad (when)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM)
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.State (MonadState, StateT, evalStateT, get, modify)
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Control.Monad.Trans.Resource (MonadResource, runResourceT)
import Data.Aeson qualified as J
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.List (isPrefixOf, isSuffixOf, sort)
import Data.Tagged (Tagged (Tagged), untag)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Time (getCurrentTimeZone, utcToZonedTime)
import Data.Time.Clock (getCurrentTime)
import Foreign
import Git qualified as G
import Git.Libgit2 qualified as GB
import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath)
import Text.Printf (printf)
import Prelude hiding (readFile, writeFile)

newtype StoreT m a = StoreT
  { runStoreT :: StateT State (ReaderT Env m) a
  }
  deriving
    ( Applicative,
      Functor,
      Monad,
      MonadReader Env,
      MonadState State,
      MonadCatch,
      MonadThrow,
      MonadIO,
      MonadMask,
      MonadResource
    )

data Env = Env
  { repo :: GB.LgRepo,
    ref :: G.RefName
  }

data State = State
  { cid :: G.CommitOid GB.LgRepo,
    tid :: G.TreeOid GB.LgRepo
  }

instance MonadTrans StoreT where
  lift = StoreT . lift . lift

type StoreM = StoreT IO

withStore :: FilePath -> G.RefName -> StoreM a -> IO a
withStore repoPath ref action = do
  repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath}
  (cid, tid) <- G.runRepository GB.lgFactory repo do
    Just cid <- fmap Tagged <$> G.resolveReference ref
    tid <- (.commitTree) <$> G.lookupCommit cid
    pure (cid, tid)

  runReaderT
    (evalStateT (runStoreT action) (State {cid, tid}))
    (Env {repo, ref})
    `finally` G.runRepository GB.lgFactory repo G.closeRepository

withCommit :: G.CommitOid GB.LgRepo -> StoreM a -> StoreM a
withCommit cid action = do
  Env {repo, ref} <- ask
  liftIO do
    tid <- G.runRepository GB.lgFactory repo do
      (.commitTree) <$> G.lookupCommit cid
    runReaderT
      (evalStateT (runStoreT action) (State {cid, tid}))
      (Env {repo, ref})

listDirectory :: FilePath -> StoreM [FilePath]
listDirectory dir' = do
  State {tid} <- get
  Env {repo} <- ask
  lift $ G.runRepository GB.lgFactory repo $ do
    let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
        n = length (splitPath dir)
    tree <- G.lookupTree tid
    sort
      . map (makeRelative dir)
      . filter ((== n + 1) . length . splitPath)
      . filter (isPrefixOf (addTrailingPathSeparator dir))
      . map fst
      . map
        ( \e ->
            case snd e of
              G.BlobEntry _ _ -> e
              G.CommitEntry _ -> error "XXX commit entry"
              G.TreeEntry _ -> first addTrailingPathSeparator e
        )
      . map (first (("/" <>) . B.toString))
      <$> G.listTreeEntries tree

listFiles :: FilePath -> StoreM [FilePath]
listFiles =
  fmap (filter (not . (isSuffixOf "/"))) . listDirectory

listAllFiles :: StoreM [FilePath]
listAllFiles = do
  State {tid} <- get
  Env {repo} <- ask
  lift $ G.runRepository GB.lgFactory repo $ do
    tree <- G.lookupTree tid
    filter (not . isSuffixOf "/")
      . sort
      . map fst
      . map
        ( \e ->
            case snd e of
              G.BlobEntry _ _ -> e
              G.CommitEntry _ -> error "XXX commit entry"
              G.TreeEntry _ -> first addTrailingPathSeparator e
        )
      . map (first (("/" <>) . B.toString))
      <$> G.listTreeEntries tree

data DoesNotExist = DoesNotExist String FilePath
  deriving (Show)

instance Exception DoesNotExist

data InappropriateType = InappropriateType String FilePath
  deriving (Show)

instance Exception InappropriateType

data DecodeException = DecodeException String
  deriving (Show)

instance Exception DecodeException

class Readable a where
  readFile :: FilePath -> StoreM a

instance Readable T.Text where
  readFile = readFile' G.catBlobUtf8

instance Readable B.ByteString where
  readFile = readFile' G.catBlob

instance Readable LB.ByteString where
  readFile = readFile' G.catBlobLazy

instance Readable J.Value where
  readFile = fmap (either (throw . DecodeException) id . J.eitherDecode) . readFile

readFile' ::
  (G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
  FilePath ->
  StoreM a
readFile' cat (makeRelative "/" -> fp) = do
  State {tid} <- get
  Env {repo} <- ask
  lift $ G.runRepository GB.lgFactory repo do
    tree <- G.lookupTree tid
    maybe
      (throwM (DoesNotExist "readFile" fp))
      ( \e ->
          case e of
            G.BlobEntry bid _ -> cat bid
            G.CommitEntry _ -> error "XXX commit entry"
            G.TreeEntry _ -> throwM (InappropriateType "readFile" fp)
      )
      =<< G.treeEntry tree (B.fromString fp)

writeFile :: FilePath -> LB.ByteString -> StoreM ()
writeFile (B.fromString . makeRelative "/" -> fp) v = do
  State {tid} <- get
  Env {repo} <- ask
  tid' <- lift $ G.runRepository GB.lgFactory repo do
    bid <- G.createBlobUtf8 (T.decodeUtf8 (LB.toStrict v))
    G.mutateTreeOid tid do
      G.putBlob fp bid
  modify $ \s -> s {tid = tid'}

deleteFile :: FilePath -> StoreM ()
deleteFile (B.fromString . makeRelative "/" -> fp) = do
  State {tid} <- get
  Env {repo} <- ask
  tid' <- lift $ G.runRepository GB.lgFactory repo do
    G.mutateTreeOid tid do
      G.dropEntry fp
      G.currentTreeOid
  modify $ \s -> s {tid = tid'}

commit :: StoreM ()
commit = do
  State {cid, tid} <- get
  Env {repo, ref} <- ask
  now <- lift (utcToZonedTime <$> getCurrentTimeZone <*> getCurrentTime)
  let sig = G.Signature "author" "email" now
  cid' <-
    lift $ runResourceT $ G.runRepository GB.lgFactory repo do
      cid' <-
        G.commitOid
          <$> G.createCommit [cid] tid sig sig "auto-commit" (Just ref)
      when (ref == "HEAD") $ reset cid'
      pure cid'
  modify $ \s -> s {cid = cid'}

reset :: MonadIO m => GB.CommitOid -> ReaderT GB.LgRepo m ()
reset cid = do
  repo <- GB.getRepository
  liftIO $ withForeignPtr (GB.repoObj repo) $ \repoPtr -> do
    withForeignPtr (GB.getOid (untag cid)) $ \oidPtr -> do
      alloca $ \cidPtr' -> do
        exitCode <- B.c'git_object_lookup cidPtr' repoPtr oidPtr B.c'GIT_OBJ_COMMIT
        when (exitCode /= 0) do
          error (printf "unknown commit %s (%d)" (show cid) (fromIntegral exitCode :: Int))
        cidPtr <- peek cidPtr'
        exitCode <- B.c'git_reset repoPtr cidPtr B.c'GIT_RESET_HARD
        when (exitCode /= 0) do
          error (printf "reset failed (%d)" (fromIntegral exitCode :: Int))