darcsden 0.4 → 0.5
raw patch · 4 files changed
+205/−34 lines, 4 filesdep +blaze-htmldep +highlighterdep +pcre-lightdep −QuickCheckdep −transformersdep ~darcsdep ~hspdep ~mtlnew-component:exe:darcsden-post-hook
Dependencies added: blaze-html, highlighter, pcre-light, pureMD5, text, xml
Dependencies removed: QuickCheck, transformers
Dependency ranges changed: darcs, hsp, mtl, snap-core, snap-server
Files
- darcsden.cabal +23/−10
- src/PostHook.hs +103/−0
- src/SSHServer.hs +35/−17
- src/WebServer.hs +44/−7
darcsden.cabal view
@@ -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
+ src/PostHook.hs view
@@ -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
src/SSHServer.hs view
@@ -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
src/WebServer.hs view
@@ -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}") ]) ]) ]