Repository.hs

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-}
module DarcsDen.Handler.Repository where

import Control.Monad (when)
import Control.Monad.Trans
import Data.Char (toLower, isSpace)
import Data.List (groupBy, inits, isPrefixOf, nub, partition, sortBy, elemIndex)
import Data.List.Split (wordsBy)
import Data.Map ((!))
import Data.Maybe (catMaybes, fromJust, isJust, isNothing)
import Data.Ord (comparing)
import Data.Time (getCurrentTime)
import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory)
import System.Exit(ExitCode(..))
import System.FilePath ((</>))
import System.FilePath.Posix (isValid)
import System.IO (openFile, hClose, hGetContents, IOMode(..))
import System.Process (readProcessWithExitCode)
import Database.CouchDB (doc)
import Snap.Core

import qualified Darcs.Repository as R
import qualified Darcs.Patch.V1.Core as P
import qualified Darcs.Patch.Prim.V1.Core as Pr

#ifdef DARCS28
import Darcs.Commands.Record (record)
import Darcs.Flags (DarcsFlag(All, PatchName, Author, LookForAdds))
#else
import Darcs.UI.Commands.Optimize (doOptimizeHTTP)
import Darcs.UI.Commands.Record (record)
import Darcs.UI.Flags (DarcsFlag(All, PatchName, Author, LookForAdds))
#endif

import DarcsDen.Darcs (sanityDarcs)
import DarcsDen.Handler.Repository.Util
import DarcsDen.Handler.Repository.Browse
import DarcsDen.Handler.Repository.Changes
import DarcsDen.Handler.Repository.Forks
import DarcsDen.Settings
import DarcsDen.State.Comment
import DarcsDen.State.Issue
import DarcsDen.State.Repository
import DarcsDen.State.Session
import DarcsDen.State.User
import DarcsDen.State.Util
import DarcsDen.Util
import DarcsDen.Validate
import DarcsDen.WebUtils
import qualified DarcsDen.Pages.Repository as Page


initialize :: Page
initialize s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to create a repository." s
    redirectTo (baseUrl ++ "login")
initialize s = doPage (Page.init []) s

doInitialize :: Page
doInitialize s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to create a repository." s
    redirectTo (baseUrl ++ "login")
doInitialize s@(Session { sUser = Just n }) = validate
    [ iff
        (And (nonEmpty "name") $
            predicate "name" isSane
                "contain only alphanumeric characters, -, or _")
        (\(OK i) ->
            io "destination repository already exists" $
                fmap isNothing (getRepository (n, i ! "name")))

    -- , Or (isEmpty "bootstrap")
    --     (Predicate "bootstrap"
    --                ((`elem` ["http", "https"]) . takeWhile (/= ':'))
    --                "start with http:// or https://")

    , io "user is not valid" (fmap (/= Nothing) (getUser n))
    ]
    (\(OK r) -> do
        now <- liftIO getCurrentTime
        desc <- input "description" ""
        site <- input "website" ""
        private <- getParam "private"
        issuetracker <- getParam "issuetracker"

        let repo = Repository
                { rID = Nothing
                , rRev = Nothing
                , rName = r ! "name"
                , rOwner = n
                , rDescription = desc
                , rWebsite = site
                , rCreated = now
                , rForkOf = Nothing
                , rMembers = []
                , rIsPrivate = isJust private
                , rIssueTracker = isJust issuetracker
                , rIssueCount = 0
                , rBuiltPacks = Nothing
                }

        -- url <- input "bootstrap" ""
        -- if length url > 0
        --     then bootstrapRepository repo url
        --     else
        newRepository repo

        success "Repository created." s
        redirectTo $ baseUrl ++ n ++ "/" ++ (r ! "name"))
    (\(Invalid f) -> do
        is <- getInputs
        notify Warning s f
            >>= doPage (Page.init is))

explore :: Page
explore s = do
    page <- input "page" "1"

    let p = read page :: Int
        perpage = 500
        paginated rs =
            paginate perpage p $
                sortBy (comparing (map toLower . rName . fst)) rs

    rs <- fmap groupForks getRepositories

    let totalPages = ceiling ((fromIntegral (length rs) :: Double) / fromIntegral perpage)

    doPage (Page.explore (paginated rs) p totalPages) s
  where
    groupForks rs = foldr addFork (map (flip (,) []) roots) forks
      where
        (forks, roots) = partition (isJust . rForkOf) rs

    addFork f [] = [(f, [])]
    addFork f ((r@(Repository { rID = y }), fs):rs)
        | rForkOf f == y = ((r, (f:fs)) : rs)
        | otherwise = (r, fs) : addFork f rs

buildPacks :: User -> Repository -> Page
buildPacks _ r s = validate
    [ io "you do not own this repository" $
        return $ Just (rOwner r) == sUser s
    ]
    (\(OK _) -> (liftIO $ do
#ifdef DARCS28
       warn "Packs not supported by this darcs version" s
#else
       Right dr <- getRepo (repoDir (rOwner r) (rName r)) :: IO (Either String (R.Repository (P.Patch Pr.Prim) wR wU wT))
       od <- getCurrentDirectory
       setCurrentDirectory $ repoDir (rOwner r) (rName r)
       doOptimizeHTTP dr
       success "Packs enabled" s
       setCurrentDirectory od
       now <- getCurrentTime
       updateRepository r { rBuiltPacks = Just now}
#endif
     ) >> redirectTo (baseUrl ++ (rOwner r) ++ "/" ++ (rName r)))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

browseRepo :: User -> Repository -> Page
browseRepo u r s = do
    Right dr <- liftIO $ getRepo (repoDir (rOwner r) (rName r)) :: Snap (Either String (R.Repository (P.Patch Pr.Prim) wR wU wT))

    member <-
        case sUser s of
            Just un ->
                return (un `elem` rMembers r)
            Nothing ->
                return False

    f <- filePath
    fs <- liftIO $ getFiles dr f
    bl <- liftIO $ getBlob dr f

    case (fs, bl) of
        (Nothing, Nothing) -> notFound
        (Just fs', _) -> do
            readme <- liftIO $ getReadme dr f

            let files =
                    map (\i -> i
                        { iPath = pathToFile (f ++ [iName i])
                        }) fs'

            doPage (Page.repo u r files (crumb f) readme member) s
        (_, Just big) | isTooLarge big ->
            doPage (Page.blob u r (crumb f) Nothing) s
        (_, Just md) | isMarkdown (last f) ->
            doPage (Page.blob u r (crumb f) (Just . Left . doMarkdown' . fromLBS $ md)) s
        (_, Just source) -> do
            source' <- liftIO $ return $! Right $! highlightBlob (last f) (strictLBS source)
            doPage
                (Page.blob u r
                    (crumb f)
                    (Just source'))
                s
  where
    filePath = do
        rq <- getRequest
        return (wordsBy (== '/') (fromBS $ rqPathInfo rq))

    crumb = map pathToRepoItem . tail . inits

    pathToRepoItem p =
        RepoItem
            { iName = last p
            , iPath = pathToFile p
            , iIsDirectory = True
            }

addFile :: User -> Repository -> Page
addFile u r s = do
   let member = case sUser s of
                   Just un -> (un `elem` rOwner r:rMembers r)
                   Nothing -> False
   if member
    then do
       f <- filePath
       doPage (Page.addFile u r (crumb f)) s
    else do
       fp <- fmap (fromBS.rqPathInfo) getRequest
       warn "You do not have permission to edit this repository" s
       redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/browse/" ++ fp)
  where
    filePath = do
        rq <- getRequest
        return (wordsBy (== '/') (fromBS $ rqPathInfo rq))

    crumb = map pathToRepoItem . tail . inits

    pathToRepoItem p =
        RepoItem
            { iName = last p
            , iPath = pathToFile p
            , iIsDirectory = True
            }

addFilePost :: User -> Repository -> Page
addFilePost _ r s = validate [
      nonEmpty "message",
      If (And (predicate "filepath" (const $ True) "") (nonEmpty "filename"))
         (\(OK a) -> io "invalid filename" $ return $ isValid ((a!"filepath") </> (a!"filename")))
   ]
   (\(OK a) -> do
   let member = case sUser s of
                   Just un -> (un `elem` rOwner r:rMembers r)
                   Nothing -> False
   if member
    then do
       t <- input "type" "file"
       let fp = a ! "filepath"
           fn = a ! "filename"
	   msg = a ! "message"
       let Just un = sUser s
       Just email <- fmap (fmap uEmail) (getUser un)
       liftIO $ do
          od <- getCurrentDirectory
          setCurrentDirectory $ repoDir (rOwner r) (rName r)
          if t == "directory"
           then createDirectory (fp </> fn)
   	   else writeFile (fp </> fn) ""
          sanityDarcs record [All, PatchName msg, Author email, LookForAdds] []
          setCurrentDirectory od
       success (t ++ " created") s
       redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/browse/" ++ (fp </> fn))
    else do
       warn "You do not have permission to edit this repository" s
       redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/browse/" ++ (a!"filepath")))
   (\(Invalid f) -> do
      notify Warning s f
      fp <- input "filepath" ""
      redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/add-file/" ++ fp))

editFile :: User -> Repository -> Page
editFile u r s = do
   let member = case sUser s of
                   Just un -> (un `elem` rOwner r:rMembers r)
                   Nothing -> False
   if member
    then do
       fp <- fmap (fromBS.rqPathInfo) getRequest
       let path' = repoDir (rOwner r) (rName r) </> fp
       mime <- getMime path'
       contents <- liftIO $ readFile path'
       f <- filePath
       Just s' <- getSession (sID s)
       doPage (Page.editFile u r (crumb f) mime contents) s'
    else do
       fp <- fmap (fromBS.rqPathInfo) getRequest
       warn "You do not have permission to edit this file" s
       redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/browse/" ++ fp)
  where
    filePath = do
        rq <- getRequest
        return (wordsBy (== '/') (fromBS $ rqPathInfo rq))

    crumb = map pathToRepoItem . tail . inits
    
    getMime p = do
        (exc, st_out, _) <- liftIO $ readProcessWithExitCode xdgMimePath ["query", "filetype", p] ""
        if exc == ExitSuccess
         then return $ filter (not.isSpace) $ removeCharset st_out
         else do
             warn "Unable to identify file type, defaulting to plain text" s
             return $ "text/plain"

    removeCharset xs = maybe xs (flip take xs) (elemIndex ';' xs)

    pathToRepoItem p =
        RepoItem
            { iName = last p
            , iPath = pathToFile p
            , iIsDirectory = True
            }

editFilePost :: User -> Repository -> Page
editFilePost _ r s = do
   let member = case sUser s of
                   Just un -> (un `elem` rOwner r:rMembers r)
                   Nothing -> False
   if member
    then do
       ntext <- input "editor" ""
       msg <- input "message" ""
       fp <- fmap (fromBS.rqPathInfo) getRequest
       let Just un = sUser s
       Just email <- fmap (fmap uEmail) (getUser un)
       liftIO $ do
          od <- getCurrentDirectory
          setCurrentDirectory $ repoDir (rOwner r) (rName r)
          handle <- openFile fp ReadMode
          has_carriage_returns <- fmap (or.map (=='\r')) (hGetContents handle)
          hClose handle
          let ntext' = if has_carriage_returns then ntext else filter (not.(=='\r')) ntext
          writeFile fp ntext'
          sanityDarcs record [All, PatchName msg, Author email] [fp]
          setCurrentDirectory od
       success "File edited." s
       redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/browse/" ++ fp)
    else do
       fp <- fmap (fromBS.rqPathInfo) getRequest
       warn "You do not have permission to edit this file" s
       redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/browse/" ++ fp)

repoChanges :: User -> Repository -> Page
repoChanges u r s = do
    p <- input "page" "1"
    let page = read p
    (patches, totalPages) <- liftIO $ getChanges (repoDir (rOwner r) (rName r)) page

    doPage (Page.changes u r patches page totalPages) s

repoChangesAtom :: User -> Repository -> Page
repoChangesAtom u r s = do
    (patches, _) <- liftIO $ getChanges (repoDir (rOwner r) (rName r)) 1
    doAtomPage (Page.changesAtom u r patches) s

-- repoPatch1 :: User -> Repository -> Page
-- repoPatch1 u r s = do
--     p <- input "id" ""
--     when (null p) (errorPage "No patch ID specified.")

--     mpatch <- liftIO $ getPatch (repoDir (rOwner r) (rName r)) p
--     case mpatch of
--       Nothing -> notFound
--       Just patch ->
--         doPage
--           (Page.patch1 u r
--            (pPatch patch)
--            (summarize (pChanges patch))
--            (filter isModification (pChanges patch)))
--           s

repoPatch :: User -> Repository -> Page
repoPatch u r s = do
    p <- input "id" ""
    when (null p) (errorPage "No patch ID specified.")
    doPage (Page.patch u r p) s

renderedpatch :: User -> Repository -> Page
renderedpatch u r s = do
  p <- input "id" ""
  when (null p) (errorPage "No patch ID specified.")
  mpatch <- liftIO $ getPatch (repoDir (rOwner r) (rName r)) p
  case mpatch of
    Nothing -> notFound
    Just patch -> -- doPage (Page.renderedpatchHtml1 u r patch) s
        doPage
          (Page.renderedpatchHtml u r
           (pPatch patch)
           (summarize (pChanges patch))
           (filter isModification (pChanges patch)))
          s

editRepo :: User -> Repository -> Page
editRepo u r s = validate
    [ io "you do not own this repository" $
        return $ Just (rOwner r) == sUser s
    ]
    (\(OK _) -> do
        ms <- mapM getUser (rMembers r)

        let members = map fromJust . filter (/= Nothing) $ ms

        doPage (Page.edit u r members []) s)
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

doEditRepo :: User -> Repository -> Page
doEditRepo _ r s = validate
    [ io "you do not own this repository" $
        return $ Just (rOwner r) == sUser s

    , nonEmpty "name"

    , predicate "name" isSane
        "contain only alphanumeric characters, -, or _"
    ]
    (\(OK i) -> do
        removed <- removeMembers r (rMembers r)

        toAdd <- input "add-members" ""
        added <- addMembers removed (map strip . wordsBy (== ',') $ toAdd)
        new <- rename added (i ! "name")

        desc <- input "description" (rDescription r)
        site <- input "website" (rWebsite r)
        private <- getParam "private"
        issuetracker <- getParam "issuetracker"
        updateRepository
            new { rDescription = desc
                , rWebsite = site
                , rIsPrivate = isJust private
                , rIssueTracker = isJust issuetracker
                }

        success "Repository updated." s

        redirectTo (baseUrl ++ (rOwner r) ++ "/" ++ (i ! "name") ++ "/edit"))
    (\(Invalid f) -> do
        notify Warning s f
        redirectTo (baseUrl ++ (rOwner r) ++ "/" ++ (rName r) ++ "/edit"))
  where
    rename r' n
        = if rName r' /= n
             then do
                 res <- renameRepository n r'
                 case res of
                     Nothing -> do
                         warn "There was an error renaming the repository." s
                         return r'
                     Just r'' -> return r''
             else return r'

    addMembers r' [] = return r'
    addMembers r' (m:ms) = do
        user <- getUser m
        case user of
             Just (User { uName = un }) -> do
                 done <- addMember r' un
                 case done of
                     Just r'' ->
                         addMembers r'' ms
                     Nothing -> do
                         warn ("There was an error adding member " ++ un ++ ".") s
                         return r'
             _ -> do
                 warn ("Could not add member " ++ m ++ "; user does not exist.") s
                 addMembers r' ms

    removeMembers r' [] = return r'
    removeMembers r' (m:ms) = do
        remove <- getParam (toBS $ "remove-" ++ show m)
        maybe (removeMembers r' ms) (\_ -> do
            removed <- removeMember r m
            flip maybe (flip removeMembers ms) (do
                user <- getUser m
                case user of
                     Just u' -> do
                         warn ("There was an error removing member " ++ uName u' ++ ".") s
                         removeMembers r' ms
                     Nothing -> do
                         warn failDunno s
                         removeMembers r' ms) removed) remove

    failDunno = unwords
        [ "There was an error removing a member that doesn't exist."
        , "So I can't tell you who it was. Way to go."
        ]


deleteRepo :: User -> Repository -> Page
deleteRepo u r s = validate
    [ io "you do not own this repository" $
        return $ Just (rOwner r) == sUser s
    ]
    (\(OK _) -> doPage (Page.delete u r) s)
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

doDeleteRepo :: User -> Repository -> Page
doDeleteRepo _ r s = validate
    [ io "you do not own this repository" $
        return $ Just (rOwner r) == sUser s
    ]
    (\(OK _) -> do
        destroyed <- destroyRepository r

        if destroyed
           then do
               success "Repository deleted." s
               redirectTo baseUrl
           else do
               warn "Repository deletion failed." s
               redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r))
    (\(Invalid f) -> do
        notify Warning s f
        redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r))

forkRepo :: User -> Repository -> Page
forkRepo _ _ s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to fork a repository." s
    redirectTo baseUrl
forkRepo u r s@(Session { sUser = Just n }) = validate
    [ io "destination repository already exists" $
        fmap isNothing (getOwnerRepository (n, rName r))
    ]
    (\(OK _) -> do
        forked <- forkRepository n (rName r) r
        success "Repository forked." s
        redirectTo (baseUrl ++ n ++ "/" ++ rName forked))
    (\(Invalid _) -> doPage (Page.fork u r (rName r)) s)

forkRepoAs :: User -> Repository -> Page
forkRepoAs _ _ s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to fork a repository." s
    redirectTo baseUrl
forkRepoAs u r s@(Session { sUser = Just n }) = validate
    [ iff (nonEmpty "name") $ \(OK i) ->
        io "destination repository already exists" $
            fmap isNothing (getRepository (n, i ! "name"))
    ]
    (\(OK i) -> do
        forked <- forkRepository n (i ! "name") r
        success "Repository forked." s
        redirectTo (baseUrl ++ n ++ "/" ++ rName forked))
    (\(Invalid _) -> do
        name <- input "name" (rName r)
        doPage (Page.fork u r name) s)

repoPatches :: User -> Repository -> Page
repoPatches u r s = do
    fs <- getRepositoryForks (fromJust $ rID r)
    upstream <- liftIO $ getUpstreamChanges r
    downstream <- liftIO $ mapM getDownstreamChanges fs

    ownPrivFs <- fmap (filter isPrivateFork) (getOwnerRepositories (uName u))
    ownPrivForks <- liftIO $ mapM getDownstreamChanges ownPrivFs

    let changes     = filter (canView (sUser s) . fRepo) $ catMaybes (upstream : downstream)
        privChanges = filter (canView (sUser s) . fRepo) $ catMaybes ownPrivForks

    doPage (Page.patches u r changes privChanges) s
  where
    isPrivateFork (Repository { rIsPrivate = True, rForkOf = f }) = f == rID r
    isPrivateFork _ = False

repoMerge :: User -> Repository -> Page
repoMerge _ r s = validate
    [ io "you do not own this repository" $
        return $ canMerge (sUser s) r
    ]
    (\(OK _) -> do
        is <- getInputs
        let ps = map (\(n, _) ->
                       let split = wordsBy (== ':') n
                       in (doc (split !! 1), split !! 2))
                     (filter (\(n, _) -> "merge:" `isPrefixOf` n) is)
            gps = groupBy (\a b -> fst a == fst b) ps
            groupedPatches = map (\r'@((k, _):_) -> (k, map snd r')) gps

        merge <- mapM (\(r', ps') -> do
                          Just f <- getRepositoryByID r'
                          liftIO $ mergePatches r f ps' s) groupedPatches

        when (and merge) (success "Patches merged!" s >> return ())

        redirectTo (baseUrl ++ rOwner r ++ "/" ++ rName r ++ "/patches"))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

repoIssuesOpen :: User -> Repository -> Page
repoIssuesOpen u r s = do
    issues <- fmap (sortBy (flip $ comparing iUpdated)) $ getIssuesOpen r
    doPage (Page.issues u r "open issues" issues) s

repoIssuesClosed :: User -> Repository -> Page
repoIssuesClosed u r s = do
  issues <- fmap (sortBy (flip $ comparing iUpdated)) $ getIssuesClosed r
  doPage (Page.issues u r "closed issues" issues) s
  
repoIssuesAll :: User -> Repository -> Page
repoIssuesAll u r s = do
  issues <- fmap (sortBy (flip $ comparing iUpdated)) $ getIssuesAll r
  doPage (Page.issues u r "all issues" issues) s

repoIssuesTag :: User -> Repository -> Page
repoIssuesTag u r s = validate
    [ nonEmpty "tag"
    ]
    (\(OK is) -> do
        let tags = map (wordsBy (== '^')) $ wordsBy (== '~') (is ! "tag")

        issues <- orFind tags

        doPage
            (Page.issuesByTags u r
                (sortBy (flip $ comparing iUpdated) issues)
                tags)
            s)
    (\(Invalid f) -> do
        notify Warning s f
        redirectTo (repoURL r ++ "/issues"))
  where
    andFind :: [String] -> Snap [Issue]
    andFind (ft:ts) = do
        issues <- getIssuesByTag r ft
        return (foldr (\t i -> filter ((t `elem`) . iTags) i) issues ts)
    andFind _ = error "andFind: no tags"

    orFind :: [[String]] -> Snap [Issue]
    orFind as = do
        issues <- mapM andFind as
        return (nub (concat issues))

repoIssue :: User -> Repository -> Page
repoIssue u r s = validate
    [ numeric "number"
    ]
    (\(OK is) -> do
        mi <- getIssue (fromJust (rID r)) (read $ is ! "number")
        case mi of
            Just i -> do
                cs <- fmap (sortBy (comparing cUpdated)) $ getComments i
                doPage (Page.issue u r i cs) s
            Nothing -> notFound)
    (\(Invalid f) -> do
        notify Warning s f
        redirectTo (repoURL r))

newIssue :: User -> Repository -> Page
newIssue _ _ s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to create an issue." s
    redirectTo baseUrl
newIssue u r s =
    doPage (Page.newIssue u r) s

doNewIssue :: User -> Repository -> Page
doNewIssue _ _ s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to create an issue." s
    redirectTo baseUrl
doNewIssue _ r s@(Session { sUser = Just un }) = validate
    [ nonEmpty "summary"
    , Predicate "description" (const True) "be provided"
    , Predicate "tags" (const True) "be provided"
    ]
    (\(OK is) -> do
        now <- liftIO getCurrentTime
        i <- addIssue Issue
            { iID = Nothing
            , iRev = Nothing
            , iNumber = rIssueCount r + 1
            , iSummary = is ! "summary"
            , iOwner = un
            , iDescription = is ! "description"
            , iTags = map strip $ wordsBy (== ',') (is ! "tags")
            , iCreated = now
            , iUpdated = now
            , iIsClosed = False
            , iRepository = fromJust (rID r)
            }

        updateRepository r
            { rIssueCount = rIssueCount r + 1
            }

        redirectTo (issueURL r i))
    (\(Invalid f) -> do
        notify Warning s f
        redirectTo (repoURL r ++ "/new-issue"))

repoComment :: User -> Repository -> Page
repoComment _ _ s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to comment on an issue." s
    redirectTo baseUrl
repoComment _ r s@(Session { sUser = Just un }) = validate
    [ iff (numeric "number") $ \(OK is) -> io "issue does not exist" $
        fmap isJust (getIssue (fromJust (rID r)) (read $ is ! "number"))
    ]
    (\(OK is) -> do
        Just i <- getIssue (fromJust (rID r)) (read $ is ! "number")
        submit <- input "submit" ""
        summary <- input "summary" ""
        description <- input "description" ""
        c <- input "comment" ""
        ts <- fmap (map strip . wordsBy (== ',')) $ input "tags" ""

        let closed =
                case submit of
                    "and close" -> True
                    "and reopen" -> False
                    _ -> iIsClosed i

            issueChanged = or
                [ iSummary i /= summary
                , iDescription i /= description
                , not (null (diffTags (iTags i) ts))
                , iIsClosed i /= closed
                ]

            diffTags ots nts = concat
                [ map AddTag (filter (`notElem` ots) nts)
                , map RemoveTag (filter (`notElem` nts) ots)
                ]

            changes = concat
                [ if iSummary i /= summary
                    then [Summary (iSummary i) summary]
                    else []
                , if iDescription i /= description
                    then [Description (iDescription i) description]
                    else []
                , if iIsClosed i /= closed then [Closed closed] else []
                , if iTags i /= ts then diffTags (iTags i) ts else []
                ]

        if not issueChanged && null c
            then do
                warn "no changes and no comment; do something!" s
                redirectTo (issueURL r i)
            else do

        now <- liftIO getCurrentTime
        addComment Comment
            { cID = Nothing
            , cRev = Nothing
            , cBody = c
            , cChanges = changes
            , cAuthor = un
            , cIssue = fromJust (iID i)
            , cCreated = now
            , cUpdated = now
            }

        mni <-
            if issueChanged
                then updateIssue i
                    { iSummary = summary
                    , iDescription = description
                    , iTags = ts
                    , iIsClosed = closed
                    , iUpdated = now
                    }
                else return (Just i)

        case mni of
            Nothing -> do
                warn "issue could not be updated" s
                redirectTo (issueURL r i)
            Just ni -> do
                if not (null c)
                    then success "comment added" s
                    else success "issue updated" s

                redirectTo (issueURL r ni))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)