DarcsBackend.hs

module Network.Orchid.Backend.DarcsBackend (darcsBackend) where

import Control.Applicative hiding (empty)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), try)
import System.Directory (removeFile)
import System.Process (runInteractiveProcess, waitForProcess, runProcess)
import System.Exit
import qualified System.IO.UTF8 as U

#if (__GLASGOW_HASKELL__ < 609)
import Control.Exception hiding (IOException)
#else
import Control.Exception
#endif

import Misc.Commons (splitsWith, eitherToMaybe, trim)
import Network.Protocol.Uri ((/+), normalize)
import Network.Orchid.Core.Backend

#if (__GLASGOW_HASKELL__ < 609)
type IOException = Exception
#endif

type DarcsRepository = FilePath

{-
Create a Darcs wiki backend bound to the specified repository location. The
temp directory specfied will be used to store intermediate results from
patching old revisions. This directory can easily be shared with the cache
directory for the `CachingBackend' module.
-}

darcsBackend :: FilePath -> FilePath -> Backend
darcsBackend repo temp = Backend {
    store    = darcsStore    repo
  , delete   = darcsDelete   repo
  , retrieve = darcsRetrieve repo temp
  , history  = darcsHistory  repo
  }

-------- store a documents in a new darcs patch -------------------------------

darcsStore :: DarcsRepository -> FilePath -> Revision -> String -> IO ()
darcsStore repo file cha@(Revision _ author name) doc = do

  -- Write the new document to the source file.
  U.writeFile (repo /+ file) doc

  -- Add file to repository.
  runProcess "darcs" ["add", "--case-ok", file]
    (Just repo) Nothing Nothing Nothing Nothing
    >>= waitForProcess

  -- Record the changes for this file.
  runProcess "darcs" [
      "record", file
    , "--all"
    , "--patch-name=" ++ name
    , "--author=" ++ author
    ] (Just repo) Nothing Nothing Nothing Nothing
    >>= waitForProcess

  return ()

-------- delete a document from the darcs repo --------------------------------

darcsDelete :: DarcsRepository -> FilePath -> Revision -> IO ()
darcsDelete repo file cha@(Revision _ author name) = do

  -- Write the new document to the source file.
  removeFile (repo /+ file)

  -- Record the changes for this file.
  runProcess "darcs" [
      "record", file
    , "--all"
    , "--patch-name=" ++ name
    , "--author=" ++ author
    ] (Just repo) Nothing Nothing Nothing Nothing
    >>= waitForProcess

  -- TODO: cache removal.

  return ()

-------------------------------------------------------------------------------

darcsRetrieve :: DarcsRepository -> FilePath -> FilePath -> Revision -> IO (Maybe String)
darcsRetrieve repo temp file rev =
  case name rev of
    "" -> eitherToMaybe <$> (try (U.readFile (repo /+ file)) :: IO (Either IOException String))
    n  -> retrieveDiff file repo temp n

retrieveDiff :: FilePath -> FilePath -> FilePath -> String -> IO (Maybe String)
retrieveDiff file repo temp name = do

  -- Load the diff from darcs.
  (inp, out, err, pid) <-
    runInteractiveProcess "darcs" [
        "diff", file
      , "--unified"
      , "--store-in-memory"
      , "--to-patch=^" ++ (escapePatch name) ++ "$"
      ]
      (Just repo) Nothing 

  -- Pipe the diff from darcs straight to patch.
  let prev = temp ++ file ++ "?" ++ name
  pid' <- runProcess "patch" [
      "--unified"
    , "--output=" ++ prev
    ]
    (Just repo) Nothing
    (Just out) Nothing Nothing

  -- Wait for both processes in pipe to terminate.
  exit' <- waitForProcess pid'
  exit <- waitForProcess pid

  -- Return just the document or nothing on failure.
  case exit of
    ExitSuccess   -> Just <$> U.readFile (repo /+ prev)
    -- TODO: just to damn ugly.
    ExitFailure _ -> removeFile (repo /+ prev) >> return Nothing

-- Escape special characters in text that will end up in an XML document.
escapePatch :: String -> String
escapePatch []       = []
escapePatch ('(':xs) = "\\(" ++ escapePatch xs
escapePatch (')':xs) = "\\)" ++ escapePatch xs
escapePatch ('+':xs) = "\\+" ++ escapePatch xs
escapePatch ('.':xs) = "\\." ++ escapePatch xs
escapePatch (x:xs)   = x : escapePatch xs

-------- request and parse modification history -------------------------------

darcsHistory :: DarcsRepository -> FilePath -> IO (Maybe History)
darcsHistory repo file = do
  (inp, out, err, pid) <-
    runInteractiveProcess "darcs" ["changes", file] (Just repo) Nothing
  s <- pHistory <$> U.hGetContents out
  waitForProcess pid
  return s

pHistory :: String -> Maybe History
pHistory h = splitsWith "\n\n" h >>= pRevisions . snd

pRevisions :: String -> Maybe History
pRevisions his = do
  case splitsWith "\n\n" his of
    Nothing -> fmap pure $ pRevision his
    Just (c, cs) -> do
      c' <- pRevision c
      cs' <- pRevisions cs
      return (c' : cs')

pRevision :: String -> Maybe Revision
pRevision revision = do
  let tmplt = length "Sun Aug 10 19:20:52 CEST 2008"
  (inf, body) <- splitsWith "\n" revision
  let date   = take tmplt inf
      author = trim (drop tmplt inf)
      name   = dropWhile (flip elem " *") $ head $ lines body
  return $ Revision date author name