diff --git a/darcsden.cabal b/darcsden.cabal --- a/darcsden.cabal +++ b/darcsden.cabal @@ -1,5 +1,5 @@ name: darcsden -version: 0.4 +version: 0.5 synopsis: darcs project hosting and collaboration description: A web and SSH server for hosting darcs projects and collaborating with @@ -32,40 +32,53 @@ build-depends: { base >= 4 && < 5 , base64-string + , blaze-html >= 0.4.0.0 && < 0.5 , bytestring , CouchDB , containers - , darcs >= 2 && < 2.5 + , darcs >= 2.5.1 , directory , filepath , harp , hashed-storage - , hsp + , highlighter + , hsp >= 0.6 && < 0.7 , json - , mtl + , mtl >= 2 && < 2.1 , old-locale , old-time , pandoc + , pcre-light + , pureMD5 , process - , QuickCheck >= 2.0 , random , redis , SHA - , ssh >= 0.2.5 - , snap-core >= 0.2.12 - , snap-server >= 0.2.12 + , ssh >= 0.2.6 + , snap-core >= 0.4 && < 0.4.1 + , snap-server >= 0.4 && < 0.4.1 , system-uuid , split + , text , time - , transformers , xhtml + , xml } - executable darcsden-ssh hs-source-dirs: src main-is: SSHServer.hs + + if impl(ghc >= 6.12) + ghc-options: -Wall -threaded -fno-warn-unused-do-bind + else + ghc-options: -Wall -threaded + +executable darcsden-post-hook + hs-source-dirs: src + + main-is: PostHook.hs if impl(ghc >= 6.12) ghc-options: -Wall -threaded -fno-warn-unused-do-bind diff --git a/src/PostHook.hs b/src/PostHook.hs new file mode 100644 --- /dev/null +++ b/src/PostHook.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad (forM_) +import Data.Maybe (catMaybes, fromJust) +import Data.Time (getCurrentTime) +import System.Directory +import System.Environment +import System.FilePath +import Text.XML.Light +import Text.Regex.PCRE.Light.Char8 + +import DarcsDen.State.Comment +import DarcsDen.State.Issue +import DarcsDen.State.Repository +import DarcsDen.State.User +import DarcsDen.Util + + +maybeEnv :: String -> IO (Maybe String) +maybeEnv n = fmap (lookup n) getEnvironment + +main :: IO () +main = do + mps <- maybeEnv "DARCS_PATCHES_XML" + + case mps of + Nothing -> putStrLn "no darcs patch info available" + Just ps -> go ps + +go :: String -> IO () +go ps = do + here <- getCurrentDirectory + + let [owner, repo] + = reverse + . take 2 + . reverse + $ splitDirectories here + + xml = parseXML ps + + names + = catMaybes + . map nameAndAuthor + . elChildren + . head + $ onlyElems xml + + closing :: [(String, String, Int)] + closing = catMaybes (map closeMatch names) + + mr <- getOwnerRepository (owner, repo) + case mr of + Just (Repository { rID = Just rid }) -> + forM_ closing $ \(e, name, num) -> do + ma <- getUserByEmail (emailFrom e) + mi <- getIssue rid num + case mi of + Just i -> do + updateIssue i { iIsClosed = True } + + now <- getCurrentTime + case ma of + Just (User { uName = author }) -> do + addComment Comment + { cID = Nothing + , cRev = Nothing + , cBody = name + , cChanges = [Closed True] + , cAuthor = author + , cIssue = fromJust (iID i) + , cCreated = now + , cUpdated = now + } + + return () + + _ -> return () + + putStrLn ("issue #" ++ show num ++ " closed") + + Nothing -> + error ("unknown issue #" ++ show num ++ "; ignoring") + + _ -> error ("unknown repository: " ++ owner ++ "/" ++ repo) + where + closeMatch (a, s) = + case match (compile regex [caseless]) s [] of + Just [_, _, n] -> Just (a, s, read n) + Just [_, _, "", n] -> Just (a, s, read n) + Just [_, _, "", "", n] -> Just (a, s, read n) + _ -> Nothing + + regex = "(closes #([0-9]+)|resolves #([0-9]+)|fixes #([0-9]+))" + + nameAndAuthor e = + case (ma, mn) of + (Just a, Just n) -> Just (a, strContent n) + _ -> Nothing + where + ma = findAttr (QName "author" Nothing Nothing) e + mn = findChild (QName "name" Nothing Nothing) e diff --git a/src/SSHServer.hs b/src/SSHServer.hs --- a/src/SSHServer.hs +++ b/src/SSHServer.hs @@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad (when) -import Control.Monad.IO.Class -import Control.Monad.Trans.State +import Control.Monad.State import Data.List (isPrefixOf) import Data.Time import SSH.Channel @@ -19,7 +17,7 @@ import DarcsDen.State.Repository import DarcsDen.State.User import DarcsDen.State.Util -import DarcsDen.Util (toLBS) +import DarcsDen.Util (toBLBS) main :: IO () @@ -53,8 +51,11 @@ case muser of Just (User { uKeys = keys }) -> do check <- mapM keyMatch keys + liftIO (putStrLn ("authorizing " ++ name ++ ": " ++ show check)) return (or check) - Nothing -> return False + Nothing -> do + liftIO (putStrLn ("authorization failed for " ++ name)) + return False where rsaPrefix = "ssh-rsa" dsaPrefix = "ssh-dsa" @@ -63,8 +64,10 @@ keyMatch k = case words k of (algo:keyBlob:_) | algo `elem` [rsaPrefix, dsaPrefix] -> - return $ blobToKey (toLBS $ Base64.decode keyBlob) == key - _ -> return False + return $ blobToKey (toBLBS $ Base64.decode keyBlob) == key + _ -> do + liftIO (putStrLn ("unknown blob: " ++ k)) + return False channelRequest :: Bool -> ChannelRequest -> Channel () channelRequest wr (Execute cmd) = @@ -75,7 +78,7 @@ saneRepo path darcsApply ["darcs", "apply", "--all", "--debug", "--repodir", path] -> saneRepo path darcsApply - [initialize, repoName] | "init" `isPrefixOf` initialize -> + (initialize:repoName:description) | "init" `isPrefixOf` initialize -> if null repoName || not (isSane repoName) then errorWith "invalid repository name" else saneUser $ \u -> do @@ -88,17 +91,24 @@ , rRev = Nothing , rName = repoName , rOwner = uName u - , rDescription = "" + , rDescription = unwords description , rWebsite = "" , rCreated = now , rForkOf = Nothing , rMembers = [] , rIsPrivate = False + , rIssueCount = 0 } finishWith "repository created" Just _ -> errorWith "repository already exists" + [oblit, repoName] | "oblit" `isPrefixOf` oblit -> + if null repoName || not (isSane repoName) + then errorWith "invalid repository name" + else saneRepo repoName obliterate ["scp", "-f", "--", path] -> safePath path scp + ["scp", "-f", path] -> + safePath path scp _ -> failWith ("invalid exec request: " ++ show cmd) where failWith :: String -> Channel () @@ -124,26 +134,26 @@ -- bar/foo/ a repository "foo" owned by user "bar"; -- current user must be a member saneRepo :: FilePath -> (Repository -> Channel ()) -> Channel () - saneRepo p a = saneUser $ \u@(User { uID = Just uid }) -> do + saneRepo p a = saneUser $ \(User { uName = un }) -> do case takeWhile (not . null) . map saneName . splitDirectories $ p of [ownerName, repoName] -> do mrepo <- getOwnerRepository (ownerName, repoName) case mrepo of - Just r | uid `elem` rMembers r -> a r + Just r | un `elem` rMembers r -> a r _ -> errorWith "invalid repository" [repoName] -> - getOwnerRepository (uName u, repoName) + getOwnerRepository (un, repoName) >>= maybe (errorWith "invalid repository") a _ -> errorWith "invalid target directory" safePath :: FilePath -> (FilePath -> Channel ()) -> Channel () - safePath p a = saneUser $ \u@(User { uID = Just uid }) -> do - cp <- liftIO (canonicalizePath ("/srv/darcs/" ++ uName u ++ "/" ++ p)) + safePath p a = saneUser $ \(User { uName = un }) -> do + cp <- liftIO (canonicalizePath ("/srv/darcs/" ++ un ++ "/" ++ p)) case takeWhile (not . null) . splitDirectories $ cp of ("/":"srv":"darcs":ownerName:repoName:_) -> do mrepo <- getOwnerRepository (ownerName, repoName) case mrepo of - Just r | ownerName == uName u || uid `elem` rMembers r -> + Just r | un `elem` (ownerName:rMembers r)-> a cp _ -> errorWith "invalid path" @@ -155,6 +165,13 @@ mu <- gets csUser >>= getUser maybe (errorWith "invalid user") a mu + obliterate r = execute . unwords $ + [ "darcs" + , "obliterate" + , "--repodir" + , repoDir (rOwner r) (rName r) + ] + darcsTransferMode r = execute . unwords $ [ "darcs" , "transfer-mode" @@ -173,8 +190,9 @@ scp path = execute . unwords $ ["scp", "-f", "--", path] execute = spawnProcess . runInteractiveCommand -channelRequest wr (Environment "LANG" _) = - when wr channelSuccess +channelRequest wr (Environment var _) + | var == "LANG" || "LC_" `isPrefixOf` var = + when wr channelSuccess channelRequest wr r = do channelError $ "this server only accepts exec requests\r\ngot: " ++ show r when wr channelFail diff --git a/src/WebServer.hs b/src/WebServer.hs --- a/src/WebServer.hs +++ b/src/WebServer.hs @@ -56,6 +56,8 @@ createDB "repositories" createDB "users" + createDB "issues" + createDB "comments" liftIO (putStrLn "creating repository design documents...") forM_ repoDesigns $ \js -> @@ -65,6 +67,14 @@ forM_ userDesigns $ \js -> newDoc (db "users") js + liftIO (putStrLn "creating issue design documents...") + forM_ issueDesigns $ \js -> + newDoc (db "issues") js + + liftIO (putStrLn "creating comment design documents...") + forM_ commentDesigns $ \js -> + newDoc (db "comments") js + liftIO (putStrLn "All set!") ("--port":p:_) -> do @@ -86,14 +96,14 @@ , " darcsden : start webserver on port 8080" ] where - startHTTP p = httpServe - "*" - p - "127.0.0.1" - (Just "/srv/darcs/access.log") - (Just "/srv/darcs/error.log") - handler + startHTTP p = httpServe (config p) handler + config p + = addListen (ListenHttp "127.0.0.1" p) + . setAccessLog (Just "/srv/darcs/access.log") + . setErrorLog (Just "/srv/darcs/error.log") + $ defaultConfig + checkDBs = do putStrLn "checking couchdb..." runDB (return ()) @@ -151,6 +161,33 @@ ]) , ("by_name", jsobj [ ("map", jsstr "function(doc) {\n if (doc.name)\n emit(doc.name, doc);\n}") + ]) + ]) + ] + ] + + issueDesigns = + [ jsobj + [ ("_id", jsstr "_design/issues") + , ("language", jsstr "javascript") + , ("views", jsobj + [ ("by_repository_and_url", jsobj + [ ("map", jsstr "function(doc) {\n emit([doc.repository, doc.url], doc);\n}") + ]) + , ("by_repository", jsobj + [ ("map", jsstr "function(doc) {\n if (!doc.is_closed)\n emit(doc.repository, doc);\n}") + ]) + ]) + ] + ] + + commentDesigns = + [ jsobj + [ ("_id", jsstr "_design/comments") + , ("language", jsstr "javascript") + , ("views", jsobj + [ ("by_issue", jsobj + [ ("map", jsstr "function(doc) {\n emit(doc.issue, doc);\n}") ]) ]) ]