Storage.hs

{-# LANGUAGE ScopedTypeVariables #-}
-- NB: clients of this module must perform locking on their own.
module DPM.Core.Storage (

  Comment, PatchesResult(..), PatchBundleName,

  withLock, setupStorageDir,

  addPatchBundle, addPatch, markAsReviewed, markAsRejected, markAsObsolete,
  markAsObsoleteNoCheck, markAsUndecided, markAsApplied, applyPatch,
  closePatchGroup, openPatchGroup, getPatches, getPatchFile, allPatchIDs,
  allConflicts, addComment

) where

import Prelude hiding ( catch )
import qualified Data.Map as Map
import System.FilePath
import qualified Data.ByteString as B
import qualified Darcs.Lock
import Control.Monad
import Control.Monad.Trans
import System.Directory ( doesFileExist, createDirectoryIfMissing )
import Control.Exception
import Data.IORef
import Data.Time ( getCurrentTime )
import Data.Maybe ( mapMaybe )
import Data.Char ( toLower )
import qualified Data.List as List
import System.IO
import System.IO.Unsafe
import Data.IORef

import DPM.Core.DataTypes
import qualified DPM.Core.Model as M
import DPM.Core.Utils
import DPM.Core.DPM_Monad
import DPM.Core.Conflicts
import DPM.Core.ReverseDependencies

type Patches = Map.Map PatchID (Patch, PatchBundleName)
type Log a = Map.Map a [LogEntry]
type Comment = String

newtype PatchBundleName = PatchBundleName { unPatchBundleName :: String }
                        deriving (Show,Read)

newtype DPMStorageVersion = DPMStorageVersion { unVersion :: Int }
                deriving (Show,Read,Eq,Ord)

ppVersion :: DPMStorageVersion -> String
ppVersion (DPMStorageVersion i) = show i

currentVersion :: DPMStorageVersion
currentVersion = DPMStorageVersion 1

withLock :: DPM a -> DPM a
withLock x =
    do fname <- getDPMConfigValue cfg_lockFile
       io <- asIO x
       liftIO $
         do -- withLock terminates the program, so we have to
            -- workaround this fact
            ref <- newIORef False
            (Darcs.Lock.withLock fname (writeIORef ref True >> io))
              `catch` (\ (e::SomeException) ->
                           do b <- readIORef ref
                              if b then throwIO e
                                   else failIO ("Could not obtain lock "
                                                ++ show fname ++
                                               ", aborting."))

setupStorageDir :: DPM ()
setupStorageDir =
    do cfg <- getDPMConfig
       liftIO $ createDirectoryIfMissing False (cfg_dataDir cfg)
       liftIO $ createDirectoryIfMissing False (cfg_reviewDir cfg)
       writeIfNonExisting (cfg_modelFile cfg) M.emptyModel
       writeIfNonExisting (cfg_patchesFile cfg) (Map.empty :: Patches)
       writeIfNonExisting (cfg_patchLog cfg) (Map.empty :: Log PatchID)
       writeIfNonExisting (cfg_patchGroupLog cfg) (Map.empty ::
                                                   Log PatchGroupID)
    where
      writeIfNonExisting :: Show a => FilePath -> a -> DPM ()
      writeIfNonExisting fname x =
          do exists <- liftIO (doesFileExist fname)
             unless exists (writeToFile fname x)

readFromFile :: Read a => FilePath -> DPM a
readFromFile fname =
    do debugDPM ("Storage: reading " ++ fname)
       s <- liftIO $ readFile fname
       liftIO $ evaluate (length s) -- force the string!
       case reads s of
         [(version, rest)] ->
             if version /= currentVersion
                then fail ("Version of storage is " ++ ppVersion version ++
                           " but DPM can handle only storage version " ++
                           ppVersion currentVersion ++
                           ". Migrate your storage if possible.")
                else case readM rest of
                       Nothing -> fail ("Content of " ++ fname ++ " corrupted")
                       Just m -> return m
         _ -> fail ("Content of " ++ fname ++ " corrupted")

writeToFile :: Show a => FilePath -> a -> DPM ()
writeToFile fname x =
    do debugDPM ("Storage: writing " ++ fname)
       liftIO $ writeFile fname (show currentVersion ++ show x)

modifyFile :: (Show a, Read a) => FilePath -> (a -> DPM a) -> DPM a
modifyFile fname trans =
    do x <- readFromFile fname
       y <- trans x
       writeToFile fname y
       return y

readModel :: DPM M.Model
readModel =
    do fname <- getDPMConfigValue cfg_modelFile
       readFromFile fname

writeModel :: M.Model -> DPM ()
writeModel model =
    do fname <- getDPMConfigValue cfg_modelFile
       writeToFile fname model

readPatches :: DPM Patches
readPatches =
    do fname <- getDPMConfigValue cfg_patchesFile
       readFromFile fname

writePatches :: Patches -> DPM ()
writePatches patches =
    do fname <- getDPMConfigValue cfg_patchesFile
       writeToFile fname patches

insertPatch :: Patch -> PatchBundleName -> Patches -> Patches
insertPatch p bname ps = Map.insert (p_id p) (p, bname) ps

lookupPatch :: PatchID -> Patches -> Maybe Patch
lookupPatch pid patches =
    do (p,_) <- Map.lookup pid patches
       return p

getPatchFile :: PatchID -> DPM FilePath
getPatchFile pid =
    do patches <- readPatches
       getPatchFileIntern patches pid

getPatchFileIntern :: Patches -> PatchID -> DPM FilePath
getPatchFileIntern patches pid =
    do case Map.lookup pid patches of
         Nothing -> fail ("Internal state inconsistent: patch with ID " ++
                          show pid ++ " not found")
         Just (_, PatchBundleName name) ->
             do dir <- getDPMConfigValue cfg_dataDir
                return (dir </> name)

withModelAndPatchesLogPG :: (M.Model -> Patches -> (M.Partial M.Model, Patches,
                                                    PatchGroupID, String))
                         -> DPM Bool
withModelAndPatchesLogPG f =
    withModelAndPatchesGeneric cfg_patchGroupLog (\m p -> return (f m p))

withModelAndPatches :: (M.Model -> Patches -> (M.Partial M.Model, Patches,
                                               PatchID, String))
                    -> DPM Bool
withModelAndPatches f = withModelAndPatchesDPM (\m p -> return (f m p))

withModelAndPatchesDPM :: (M.Model -> Patches ->
                           DPM (M.Partial M.Model, Patches,
                                PatchID, String))
                       -> DPM Bool
withModelAndPatchesDPM = withModelAndPatchesGeneric cfg_patchLog

withModelAndPatchesGeneric :: (Show a, Read a, Ord a) =>
                              (DPMConfig -> FilePath)
                           -> (M.Model -> Patches ->
                               DPM (M.Partial M.Model, Patches, a, String))
                           -> DPM Bool
withModelAndPatchesGeneric logFileFun f =
    do model <- readModel
       patches <- readPatches
       res <- f model patches
       case res of
         (Left err, _, _, _) -> fail err
         (Right model', patches', a, logMsg) ->
             do writeModel model'
                writePatches patches'
                t <- liftIO $ getCurrentTime
                user <- getDPMConfigValue cfg_currentUser
                logFile <- getDPMConfigValue logFileFun
                let logEntry = LogEntry t user (model /= model') logMsg
                modifyFile logFile
                    (\ m -> case Map.lookup a m of
                              Nothing -> return $ Map.insert a [logEntry] m
                              Just l -> return $ Map.insert a (logEntry:l) m)
                return (model /= model')

addPatchBundle :: B.ByteString -> DPM PatchBundleName
addPatchBundle bs =
    do dir <- getDPMConfigValue cfg_dataDir
       liftIO $ do (tmpFile, handle) <- openTempFile dir ".dpatch"
                   B.hPutStr handle bs
                   hClose handle
                   return (PatchBundleName (takeFileName tmpFile))

addPatch :: Patch -> PatchBundleName -> [PatchID] -> Bool -> DPM Bool
addPatch p bundleName conflicts conflictWithRepo =
    withModelAndPatchesDPM $ \model patches ->
    case M.addPatch model (p_id p) (p_name p) (p_dependents p)
           conflicts conflictWithRepo
    of
      Left err -> return (Left err, patches, p_id p, "added")
      Right model' ->
          do return (Right model',
                     insertPatch p bundleName patches,
                     p_id p,
                     "added")

markAsReviewed :: PatchID -> Comment -> DPM Bool
markAsReviewed pid comment = withModelAndPatches $
    \model patches -> (M.markAsReviewed model pid, patches,
                       pid, "marked as reviewed: " ++ comment)

markAsRejected :: PatchID -> Comment -> DPM Bool
markAsRejected pid comment = withModelAndPatches $
    \model patches -> (M.markAsDiscarded model pid ReasonRejected, patches,
                       pid, "marked as rejected: " ++ comment)

markAsObsolete :: PatchID -> Comment -> DPM Bool
markAsObsolete pid comment = withModelAndPatches $
    \model patches -> (M.markAsDiscarded model pid ReasonObsolete, patches,
                       pid, "marked as obsolete: " ++ comment)

markAsObsoleteNoCheck :: PatchID -> Comment -> DPM Bool
markAsObsoleteNoCheck pid comment = withModelAndPatches $
    \model patches -> (M.markAsDiscarded' False model pid ReasonObsolete,
                       patches, pid, "marked as obsolete: " ++ comment)

markAsUndecided :: PatchID -> Comment -> DPM Bool
markAsUndecided pid comment = withModelAndPatches $
    \model patches -> (M.markAsUndecided model pid, patches,
                       pid, "marked as undecided: " ++ comment)

markAsApplied :: PatchID -> Comment -> DPM Bool
markAsApplied pid comment = withModelAndPatches $
    \model patches -> (M.markAsApplied model pid, patches,
                       pid, "marked as applied: " ++ comment)

addComment :: PatchID -> Comment -> DPM Bool
addComment pid comment = withModelAndPatches $
    \model patches -> (Right model, patches, pid, comment)

applyPatch :: PatchID
           -> (FilePath -> DPM ()) -- Applies the patch stored in the file
           -> Maybe Comment
           -> DPM Bool
applyPatch pid applyFun comment = withModelAndPatchesDPM $
    \model patches ->
        case M.markAsApplied model pid of
          Left err -> return (Left err, patches, pid, "applied")
          Right model' ->
              do when (model' /= model) $
                      do patchFile <- getPatchFileIntern patches pid
                         applyFun patchFile
                 return (Right model', patches, pid,
                         case comment of
                           Nothing -> "applied"
                           Just s -> "applied (" ++ s ++ ")")

closePatchGroup :: PatchGroupID -> DPM Bool
closePatchGroup pgid = withModelAndPatchesLogPG $
    \model patches -> (M.closePatchGroup model pgid, patches,
                       pgid, "closed patch group")

openPatchGroup :: PatchID -> DPM Bool
openPatchGroup pid = withModelAndPatchesLogPG $
    \model patches ->
        case M.openPatchGroup model pid of
          Left err -> (Left err, patches,
                       error "no patch group id", "opened patch group")
          Right (model', pgid) -> (Right model', patches,
                                   pgid, "opened patch group")

data PatchesResult = PatchesResult { pr_groups :: [PatchGroup (Patch, FilePath)]
                                   , pr_revDeps :: PatchRevDeps
                                   , pr_allPatchIDs :: [PatchID]
                                   , pr_allConflicts :: PatchConflicts }

-- FIXME: test filtering
getPatches :: Query -> DPM PatchesResult
getPatches query =
    do model <- readModel
       patches <- readPatches
       let allPatchIDs = Map.keys patches
           patches' = M.getPatches model
           revDeps = buildRevDeps (map (\(p,_) -> (p_id p, p_dependents p))
                                       (Map.elems patches))
       logFile <- getDPMConfigValue cfg_patchLog
       logMap <- readFromFile logFile
       allGroups <- mapM (convertPG logMap patches) patches'
       let matchingGroups = mapMaybe (filterPatchGroups revDeps) allGroups
       return $ PatchesResult matchingGroups revDeps
                              allPatchIDs (M.allConflicts model)
    where
      -- Conversion of patches and groups (injects additional info etc.)
      convertPG :: Log PatchID -> Patches -> PatchGroup (M.Patch PatchState)
                -> DPM (PatchGroup (Patch, FilePath))
      convertPG logMap allPatches (PatchGroup id state ps c) =
          do ps' <- mapM (retrievePatch logMap allPatches) ps
             return $ PatchGroup id state ps' c
      retrievePatch :: Log PatchID -> Patches -> M.Patch PatchState
                    -> DPM (Patch, FilePath)
      retrievePatch logMap patches mp =
          case lookupPatch (M.p_id mp) patches of
            Nothing -> fail ("Internal state inconsistent: patch with ID " ++
                             show (M.p_id mp) ++ " not found")
            Just p ->
                do let log = case Map.lookup (p_id p) logMap of
                               Nothing -> []
                               Just l -> l
                   patchFile <- getPatchFileIntern patches (p_id p)
                   return $
                     (p { p_state = M.p_state mp
                        , p_tags = if M.p_isReviewed mp then [TagReviewed]
                                                        else []
                        , p_log = log }
                     ,patchFile)
      -- Filtering
      filterPatchGroups :: PatchRevDeps -> PatchGroup (Patch, FilePath)
                        -> Maybe (PatchGroup (Patch, FilePath))
      filterPatchGroups revDeps pg =
          let patches = pg_patches pg
              patches' = filter (matchesPatch revDeps (pg_state pg)) patches
          in if null patches'
                then Nothing
                else Just $ pg { pg_patches = patches'
                               , pg_complete = (length patches ==
                                                length patches') }
      matchesPatch :: PatchRevDeps -> PatchGroupState
                   -> (Patch, FilePath) -> Bool
      matchesPatch revDeps pgState (p, _) =
          let strings = [prettyDate (p_date p),
                         unPatchGroupID (p_name p),
                         p_author p]
              trailingStrings = [unPatchID (p_id p)] ++
                                (map unPatchID (p_dependents p)) ++
                                (map unPatchID (getRevDeps revDeps (p_id p)))
          in evalQuery query pgState p
               (map (\s -> (s, False)) strings ++
                map (\s -> (s, True)) trailingStrings)
      evalQuery :: Query -> PatchGroupState -> Patch
                -> [(String, Bool)] -- snd indicates if only trailing part should
                                    -- be matched
                -> Bool
      evalQuery q pgState patch strings =
          eval q
          where
            eval (QPrim s) = any (matchesString s) strings
            eval (QAnd q1 q2) = eval q1 && eval q2
            eval (QOr q1 q2) = eval q1 || eval q2
            eval (QNot q') = not (eval q')
            eval (QState pState) = p_state patch == pState
            eval (QGroupState pgState') = pgState == pgState'
            eval (QPatchID id) = unPatchID (p_id patch) == id
            eval QReviewed = isReviewed patch
            eval QTrue = True
            eval QFalse = False
      matchesString queryStr (existingStr, trailingOnly) =
              let lowerQueryStr = map toLower queryStr
                  lowerExistingStr = map toLower existingStr
                  pred = if trailingOnly then List.isSuffixOf else List.isInfixOf
              in lowerQueryStr `pred` lowerExistingStr

allPatchIDs :: DPM [PatchID]
allPatchIDs =
    do patches <- readPatches
       return $ Map.keys patches

allConflicts :: DPM PatchConflicts
allConflicts =
    do model <- readModel
       return (M.allConflicts model)