module DisTract.Bug
(makeNewBug,
loadBug,
updateBug
)
where
import System.Directory
import System.FilePath
import System.IO
import DisTract.Types
import DisTract.Layout
import DisTract.Bug.Comment
import DisTract.Bug.Field
import DisTract.Bug.PseudoField
import DisTract.Monotone.Interaction
import Data.Maybe
import Data.Time
import qualified Data.Map as M
import qualified JSON as J
makeNewBug :: Config -> String -> M.Map String J.Value -> IO Bug
makeNewBug config@(Config { user = user, logger = logger }) comment fields
= do { now <- getCurrentTime
; let bid = bid' now
; let bidStr = show bid
; logStr logger $ bidStr
; let bugPath = bugIdToPath config bid
; exists <- doesDirectoryExist bugPath
; result <- if exists
then makeNewBug config comment fields
else do { branchBase <- mtnFindCurrentBranch config bugs
; let newBranch = branchBase ++ ('.':bidStr)
; mtnSetupBranch config newBranch bugPath
; addBugBranchFiles bugPath bid
; createDirectory (combine bugPath commentsDir)
; createDirectory (combine bugPath fieldsDir)
; comments <- writeComment config bid comment Nothing
; fieldsValidated <- writeFields config bid fields
; mtnAddUnknownFiles config bugPath
; hash <- mtnCommit config bugPath (summariseBug bidStr fieldsValidated) []
; logStr logger $ "Committed revision " ++ (show hash)
; let bug = Bug bid comments fieldsValidated
; bug' <- loadPseudoFields config bug
; return bug'
}
; return result
}
where
bid' = flip BugId user
summariseBug :: String -> FieldValues -> String
summariseBug bugIdStr fields
= unlines $ ("Creation of bug " ++ bugIdStr)
: (M.foldWithKey summariseField [] fields)
summariseField :: String -> FieldValue -> [String] -> [String]
summariseField key (FieldValue value _) acc
= ((key ++ padding ++ value) : acc)
where
padding = replicate (15 (length key)) ' '
addBugBranchFiles :: FilePath -> BugId -> IO ()
addBugBranchFiles path bid
= do { h <- openFile uidPath WriteMode
; hPutStrLn h $ show bid
; hClose h
}
where
uidPath = combine path uidFile
uidFile :: FilePath
uidFile = "bugId"
loadBug :: Config -> BugId -> IO (Maybe Bug)
loadBug config bid
= do { exists <- doesDirectoryExist bugPath
; if exists
then loadBugFromFiles config bid >>= return . Just
else do { branchBase <- mtnFindCurrentBranch config bugs
; let bugBranch = branchBase ++ ('.':bidStr)
; log bugBranch
; branchExists <- mtnDoesBranchExist config bugBranch
; if branchExists
then do { mtnCheckOutBranch config bugs bugBranch bidStr
; loadBug config bid
}
else return Nothing
}
}
where
bugPath = bugIdToPath config bid
bidStr = show bid
log = logStr . logger $ config
loadBugFromFiles :: Config -> BugId -> IO Bug
loadBugFromFiles config bid
= do { comments <- loadComments config bid
; fields <- loadFields config bid
; let bug = Bug bid comments fields
; bug' <- loadPseudoFields config bug
; return bug'
}
updateBug :: Config -> BugId -> Maybe (String, String) -> M.Map String J.Value ->
IO (Maybe Bug)
updateBug config bid newComment newFields
= do { bugM <- loadBug config bid
; case bugM of
Nothing -> return Nothing
(Just bug) -> do { bugC <- addComment config bug newComment
; (bugCF, newFieldValues) <- updateFields config bugC newFields
; hash <- mtnCommit config bugPath (summariseBug (show bid) newFieldValues) []
; log $ "Committed revision " ++ (show hash)
; return $ Just $ bugCF
}
}
where
bugPath = bugIdToPath config bid
log = logStr . logger $ config
summariseBug :: String -> [FieldValue] -> String
summariseBug bugIdStr fields
= unlines $ ("Update to bug " ++ bugIdStr)
: (foldr summariseField [] fields)
summariseField :: FieldValue -> [String] -> [String]
summariseField (FieldValue value field) acc
= ((key ++ padding ++ value) : acc)
where
padding = replicate (15 (length key)) ' '
key = fieldName field