darcsweb - src/DarcsWeb/Darcs.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module DarcsWeb.Darcs
  ( listRepos
  , getRepoPatches
  , getRepoPatch
  , getRepoTags
  , getRepoTree
  , getRepoBlob
  , isDarcsRepo
  -- Exported for testing
  , isSafeSubPath
  , splitPath
  ) where

import qualified Data.Text as T
import           Data.Text (Text)
import           Data.List (isPrefixOf, partition, sortBy)
import           Data.Ord (comparing)
import           System.Directory (listDirectory, doesDirectoryExist, doesFileExist,
                                   getFileSize, canonicalizePath)
import           System.FilePath ((</>))
import           Control.Exception (try, SomeException, evaluate)

import           Darcs.Repository
                   ( withRepositoryLocation
                   , RepoJob(..)
                   , readPatches
                   )
import           Darcs.Repository.Flags (UseCache(..))
import           Darcs.Patch.Info
                   ( PatchInfo
                   , piName
                   , piAuthor
                   , piDateString
                   , piLog
                   , piTag
                   , isTag
                   , makePatchname
                   )
import           Darcs.Patch.PatchInfoAnd (PatchInfoAnd, info, hopefullyM)
import           Darcs.Patch.Set (patchSet2RL)
import           Darcs.Patch.Witnesses.Ordered (mapRL)
import           Darcs.Patch.Show (ShowPatchBasic(..), ShowPatch(..), ShowPatchFor(..))
import           Darcs.Patch.RepoPatch (RepoPatch)
import           Darcs.Util.Printer (renderString)
import           Darcs.Util.Hash (sha1Show)
import qualified Data.ByteString.Char8 as BC

import qualified PathPure
import           DarcsWeb.Types

-- | Check if a directory is a darcs repository
isDarcsRepo :: FilePath -> IO Bool
isDarcsRepo path = doesDirectoryExist (path </> "_darcs")

-- | List all darcs repositories in a directory
listRepos :: FilePath -> IO [RepoInfo]
listRepos baseDir = do
    entries <- listDirectory baseDir
    repos <- mapM (checkRepo baseDir) entries
    return $ sortBy (comparing riName) (concat repos)

checkRepo :: FilePath -> String -> IO [RepoInfo]
checkRepo baseDir name = do
    let fullPath = baseDir </> name
    isDir <- doesDirectoryExist fullPath
    if not isDir
      then return []
      else do
        isRepo <- isDarcsRepo fullPath
        if not isRepo
          then return []
          else do
            desc <- readRepoDescription fullPath
            mInfo <- getBasicRepoInfo fullPath
            case mInfo of
              Nothing -> return [RepoInfo
                { riName        = T.pack name
                , riPath        = fullPath
                , riDescription = desc
                , riLastChange  = ""
                , riPatchCount  = 0
                }]
              Just (lastDate, count) -> return [RepoInfo
                { riName        = T.pack name
                , riPath        = fullPath
                , riDescription = desc
                , riLastChange  = lastDate
                , riPatchCount  = count
                }]

readRepoDescription :: FilePath -> IO Text
readRepoDescription path = do
    let descFile = path </> "_darcs" </> "prefs" </> "repo_description"
    exists <- doesFileExist descFile
    if exists
      then T.strip . T.pack <$> readFile descFile
      else return ""

getBasicRepoInfo :: FilePath -> IO (Maybe (Text, Int))
getBasicRepoInfo repoPath = do
    result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
      patches <- readPatches repository
      let infos = mapRL info (patchSet2RL patches)
          count = length infos
          lastDate = case infos of
            (i:_) -> T.pack (piDateString i)
            []    -> ""
      return (lastDate, count)
    case result of
      Left (_ :: SomeException) -> return Nothing
      Right val                 -> return (Just val)

-- | Get all patches from a repository (metadata + summary only, no diff)
getRepoPatches :: FilePath -> IO [PatchSummary]
getRepoPatches repoPath = do
    result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
      patches <- readPatches repository
      let patchRL = patchSet2RL patches
          results = mapRL extractPatchListing patchRL
      _ <- evaluate (length results)
      return results
    case result of
      Left (_ :: SomeException) -> return []
      Right val                 -> return val

-- | Get a single patch by hash (with full diff)
getRepoPatch :: FilePath -> Text -> IO (Maybe PatchSummary)
getRepoPatch repoPath targetHash = do
    result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
      patches <- readPatches repository
      let patchRL = patchSet2RL patches
          allPatches = mapRL extractPatchFull patchRL
          found = filter (\ps -> psHash ps == targetHash) allPatches
      case found of
        (p:_) -> do
          _ <- evaluate (T.length (psDiff p))
          return (Just p)
        [] -> return Nothing
    case result of
      Left (_ :: SomeException) -> return Nothing
      Right val                 -> return val

-- | Get tags from a repository
getRepoTags :: FilePath -> IO [PatchSummary]
getRepoTags repoPath = do
    allPatches <- getRepoPatches repoPath
    return $ filter psIsTag allPatches

-- | Maximum blob size to serve (10 MiB)
maxBlobSize :: Integer
maxBlobSize = 10 * 1024 * 1024

-- | Validate that a resolved path stays inside the jail directory.
--   Canonicalizes the path to resolve symlinks before checking.
jailCheck :: FilePath -> FilePath -> IO Bool
jailCheck jail path = do
    canonical <- canonicalizePath path
    let jailSlash = if null jail then "/"
                    else if last jail == '/' then jail else jail ++ "/"
    return (jailSlash `isPrefixOf` canonical || canonical == init jailSlash)

-- | Check whether a subpath is safe (no hidden/internal segments).
--   Uses formally verified implementation from Coq/Rocq.
isSafeSubPath :: FilePath -> Bool
isSafeSubPath = PathPure.is_safe_sub_path

-- | Split a file path on '/' separators.
--   Uses formally verified implementation from Coq/Rocq.
splitPath :: FilePath -> [String]
splitPath = PathPure.split_path

-- | List entries in a directory within a repository's working tree.
--   The subPath is relative to the repo root. Returns Nothing if the path
--   is not a directory, doesn't exist, or escapes the repo jail.
getRepoTree :: FilePath -> FilePath -> IO (Maybe [TreeEntry])
getRepoTree repoPath subPath = do
    let fullDir = if null subPath then repoPath else repoPath </> subPath
    isDir <- doesDirectoryExist fullDir
    if not isDir
      then return Nothing
      else do
        -- Verify the resolved path stays inside the repo
        safe <- jailCheck repoPath fullDir
        if not safe
          then return Nothing
          else do
            entries <- listDirectory fullDir
            let visible = filter (\e -> e /= "_darcs" && not ("." `isPrefixOf` e)
                                     && e /= ".git") entries
            items <- mapM (mkEntry fullDir) (sortBy compare visible)
            let (dirs, files) = partition teIsDir items
            return (Just (dirs ++ files))
  where
    mkEntry dir name = do
      let path = dir </> name
      isDir <- doesDirectoryExist path
      size <- if isDir then return 0
              else fromIntegral <$> getFileSize path
      return TreeEntry
        { teName  = T.pack name
        , teIsDir = isDir
        , teSize  = size
        }

-- | Read a file's contents from the repository working tree.
--   Returns Nothing if the file doesn't exist, is a directory, escapes
--   the repo jail, or exceeds the size limit.
getRepoBlob :: FilePath -> FilePath -> IO (Maybe Text)
getRepoBlob repoPath subPath = do
    -- Reject unsafe subpaths (hidden files, _darcs, etc.)
    if not (isSafeSubPath subPath)
      then return Nothing
      else do
        let fullPath = repoPath </> subPath
        exists <- doesFileExist fullPath
        if not exists
          then return Nothing
          else do
            -- Verify the resolved path stays inside the repo
            safe <- jailCheck repoPath fullPath
            if not safe
              then return Nothing
              else do
                size <- getFileSize fullPath
                if size > maxBlobSize
                  then return Nothing
                  else do
                    txt <- T.pack <$> Prelude.readFile fullPath
                    return (Just txt)

-- | Extract patch for listing (no diff content, just metadata + summary)
extractPatchListing :: RepoPatch p
                    => PatchInfoAnd p wA wB -> PatchSummary
extractPatchListing piap =
    let pinfo = info piap
        summaryText = case hopefullyM piap of
          Just p  -> T.pack $ renderString $ summary p
          Nothing -> ""
    in patchInfoToSummary pinfo "" summaryText

-- | Extract patch with full diff content
extractPatchFull :: RepoPatch p
                 => PatchInfoAnd p wA wB -> PatchSummary
extractPatchFull piap =
    let pinfo = info piap
        (diffText, summaryText) = case hopefullyM piap of
          Just p  -> ( T.pack $ renderString $ showPatch ForDisplay p
                     , T.pack $ renderString $ summary p
                     )
          Nothing -> ("(patch content unavailable)", "")
    in patchInfoToSummary pinfo diffText summaryText

patchInfoToSummary :: PatchInfo -> Text -> Text -> PatchSummary
patchInfoToSummary pinfo diffText summaryText = PatchSummary
    { psName    = T.pack (piName pinfo)
    , psAuthor  = T.pack (piAuthor pinfo)
    , psDate    = T.pack (piDateString pinfo)
    , psLog     = T.pack (unlines (piLog pinfo))
    , psHash    = T.pack (BC.unpack (sha1Show (makePatchname pinfo)))
    , psIsTag   = isTag pinfo
    , psTagName = T.pack <$> piTag pinfo
    , psDiff    = diffText
    , psSummary = summaryText
    }