module DisTract.Bug.Comment
(loadComments,
commentsDir,
writeComment,
addComment
)
where
import DisTract.Utils
import DisTract.Types
import DisTract.Layout
import DisTract.JSONUtils
import DisTract.Monotone.Interaction
import DisTract.Monotone.Types
import qualified JSON as J
import qualified Data.Map as M
import Data.Maybe
import Data.List
import Data.Time
import System.FilePath
import System.Directory
import Control.Monad
commentsDir :: FilePath
commentsDir = "comments"
rootCommentFile :: FilePath
rootCommentFile = "root"
commentKeyInReplyTo :: String
commentKeyInReplyTo = "InReplyTo"
commentKeyComment :: String
commentKeyComment = "Comment"
loadComments :: Config -> BugId -> IO Comment
loadComments config bugId
= do { files <- getDirectoryContents commentsPath
; comments <- mapM (readCommentFile commentsPath) files
; let commentsMaps = foldr buildCommentsMaps (M.empty, M.empty) comments
; authorsMap <- foldM fetchLog M.empty files
; return (buildComments commentsMaps authorsMap rootCommentFile)
}
where
workspace = bugIdToPath config bugId
commentsPath = combine workspace commentsDir
fetchLog :: (M.Map FilePath LogBrief) -> FilePath ->
IO (M.Map FilePath LogBrief)
fetchLog acc file
= do { isFile <- doesFileExist fullPath
; if isFile
then do { [log] <- mtnLogBrief config workspace ["--last", "1"]
. combine commentsDir $ file
; return (M.insert file log acc)
}
else return acc
}
where
fullPath = combine commentsPath file
buildComments :: (M.Map FilePath String, M.Map FilePath [FilePath]) ->
M.Map FilePath LogBrief -> FilePath -> Comment
buildComments maps@(m1, m2) m3 node = Comment node author time comment followups
where
author = logRevisionAuthor logBrief
time = logRevisionTime logBrief
(Just logBrief) = M.lookup node m3
(Just comment) = M.lookup node m1
followups = case M.lookup node m2 of
Nothing -> []
(Just next) -> map (buildComments maps m3) (sort next)
buildCommentsMaps :: Maybe (FilePath, FilePath, String) ->
(M.Map FilePath String, M.Map FilePath [FilePath]) ->
(M.Map FilePath String, M.Map FilePath [FilePath])
buildCommentsMaps Nothing maps = maps
buildCommentsMaps (Just (file, reply, comment)) (m1, m2) = (m1', m2')
where
m1' = M.insert file comment m1
m2' = M.alter buildCommentsMaps' reply m2
buildCommentsMaps' :: Maybe [FilePath] -> Maybe [FilePath]
buildCommentsMaps' Nothing = Just [file]
buildCommentsMaps' (Just rest) = Just (file:rest)
readCommentFile :: FilePath -> FilePath -> IO (Maybe (FilePath, FilePath, String))
readCommentFile path file
= do { isFile <- doesFileExist fullPath
; if isFile
then do { contents <- readFileStrict fullPath
; return $ case J.parse contents of
(Just (J.Object obj)) ->
Just (file,
lookupJsonString obj commentKeyInReplyTo,
lookupJsonString obj commentKeyComment
)
_ -> Nothing
}
else return Nothing
}
where fullPath = combine path file
writeComment :: Config -> BugId -> String -> Maybe String -> IO Comment
writeComment config@(Config{ user = user }) bid comment Nothing
= writeComment' user commentsPath comment Nothing rootCommentFile
where
bugDir = bugIdToPath config bid
commentsPath = combine bugDir commentsDir
writeComment config@(Config{ user = user }) bid comment (Just inReplyTo)
= do { now <- getCurrentTime
; let commentFileName = bugIdTimeFormatter now
; exists <- doesFileExist $ combine commentsPath commentFileName
; if exists
then writeComment config bid comment (Just inReplyTo)
else writeComment' user commentsPath comment (Just inReplyTo) commentFileName
}
where
bugDir = bugIdToPath config bid
commentsPath = combine bugDir commentsDir
writeComment' :: String -> FilePath -> String -> Maybe String -> FilePath -> IO Comment
writeComment' user commentsPath text inReplyTo commentId
= do { writeFileStrict (combine commentsPath commentId) jsonText
; now <- getCurrentTime
; return $ Comment commentId user now text []
}
where
jsonText = (J.stringify (J.Object obj)) ++ "\n"
obj = M.fromList ((commentKeyComment, J.String text):reply:[])
reply = maybe (commentKeyInReplyTo, J.String "")
((,) commentKeyInReplyTo . J.String) inReplyTo
addComment :: Config -> Bug -> Maybe (String, String) -> IO Bug
addComment _ bug Nothing = return bug
addComment config bug@(Bug bid comments _) (Just newComment)
= do { (comments', file) <- addComment' config bid newComment (comments, Nothing)
; case file of
(Just fileName) -> mtnAdd config bugDir [combine commentsDir fileName]
where
bugDir = bugIdToPath config bid
Nothing -> return ()
; return $ bug { bugComments = comments' }
}
addComment' :: Config -> BugId -> (String, String) -> (Comment, Maybe FilePath) ->
IO (Comment, Maybe FilePath)
addComment' _ _ _ cp@(_, Just _) = return cp
addComment' config bid newComment@(text, inReplyTo)
(comment@(Comment path author time body comments), Nothing)
= case inReplyTo == path of
False -> do { (comments', filePathM) <- foldM addCommentHelper ([], Nothing) comments
; return ((Comment path author time body (reverse comments')),
filePathM)
}
True -> do { now <- getCurrentTime
; let commentFileName = bugIdTimeFormatter now
; exists <- doesFileExist $ combine commentsPath commentFileName
; if exists
then addComment' config bid newComment (comment, Nothing)
else do { cmt <- writeComment' (user config) commentsPath
text (Just inReplyTo) commentFileName
; return ((Comment path author time body (comments ++ [cmt])),
Just commentFileName)
}
}
where
bugDir = bugIdToPath config bid
commentsPath = combine bugDir commentsDir
addCommentHelper :: ([Comment], Maybe FilePath) -> Comment ->
IO ([Comment], Maybe FilePath)
addCommentHelper (commentsAcc, filePathM) comment
= do { (comment', filePathM') <- addComment' config bid newComment (comment, filePathM)
; return (comment':commentsAcc, filePathM')
}