darcsden 0.5 → 1.0
raw patch · 4 files changed
+162/−183 lines, 4 filesdep +blaze-builderdep +highlighting-katedep +safedep ~darcsdep ~hspdep ~mtlnew-uploader
Dependencies added: blaze-builder, highlighting-kate, safe, utf8-string
Dependency ranges changed: darcs, hsp, mtl, snap-core, snap-server
Files
- darcsden.cabal +79/−40
- src/PostHook.hs +11/−2
- src/SSHServer.hs +14/−7
- src/WebServer.hs +58/−134
darcsden.cabal view
@@ -1,86 +1,125 @@ name: darcsden-version: 0.5-synopsis: darcs project hosting and collaboration+version: 1.0+synopsis: Darcs repository UI and hosting/collaboration app. description:- A web and SSH server for hosting darcs projects and collaborating with- others.+ A web application and SSH server for browsing and hosting darcs+ repositories and collaborating with others. .- See darcsden --readme for installation instructions.+ See the README in the source repository for installation help. cabal-version: >=1.6 build-type: Simple license: GPL license-file: LICENSE-author: Alex Suraci-maintainer: i.am@toogeneric.com-homepage: http://darcsden.com/-category: Web+author: Alex Suraci <suraci.alex@gmail.com>+maintainer: Alex Suraci <suraci.alex@gmail.com>, Simon Michael <simon@joyful.com>+homepage: http://hackage.haskell.org/package/darcsden+category: Development, Distribution, Web source-repository head type: darcs- location: http://darcsden.com/alex/darcsden+ location: http://hub.darcs.net/simon/darcsden+ -- location: http://darcsden.com/alex/darcsden -executable darcsden- hs-source-dirs: src+flag darcs28+ Description: Build with released darcs 2.8.2+, not the latest darcs-screened.+ Default: True - main-is: WebServer.hs+-- Several flags just to help with building on windows in the short term.+-- Disable these to skip the highlighting-kate, pcre-light, and ssh+-- dependencies: - if impl(ghc >= 6.12)- ghc-options: -Wall -threaded -fno-warn-unused-do-bind- else- ghc-options: -Wall -threaded+flag highlighting+ Description: Enable source code highlighting+ Default: True +flag closing+ Description: Enable closing of bugs in the post-hook+ Default: True++flag ssh+ Description: Enable ssh server for remote pushes+ Default: True++executable darcsden+ hs-source-dirs: src+ main-is: WebServer.hs+ -- not -threaded until libdarcs is working directory thread safe+ ghc-options: -Wall -fno-warn-unused-do-bind+ if flag(darcs28)+ cpp-options: -DDARCS28+ build-depends: darcs >= 2.8.2 && < 2.9+ else+ build-depends: darcs > 2.9 && < 2.10+ if flag(highlighting)+ cpp-options: -DHIGHLIGHTING+ build-depends:+ { highlighter+ , highlighting-kate+ }+ if flag(ssh)+ cpp-options: -DSSH_FLAG+ build-depends:+ ssh >= 0.2.6 build-depends:- { base >= 4 && < 5+ base >= 4 && < 5 , base64-string+ , blaze-builder >= 0.3.1.0 && < 0.4 , blaze-html >= 0.4.0.0 && < 0.5 , bytestring , CouchDB , containers- , darcs >= 2.5.1 , directory , filepath , harp , hashed-storage- , highlighter- , hsp >= 0.6 && < 0.7+ , hsp >= 0.7 && < 0.8 , json- , mtl >= 2 && < 2.1+ , mtl >= 2 && < 2.2 , old-locale , old-time , pandoc- , pcre-light , pureMD5 , process , random , redis+ , safe , SHA- , ssh >= 0.2.6- , snap-core >= 0.4 && < 0.4.1- , snap-server >= 0.4 && < 0.4.1+ , snap-core >= 0.8 && < 0.10+ , snap-server >= 0.8 && < 0.10 , system-uuid , split , text , time+ , utf8-string , 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+ hs-source-dirs: src+ main-is: SSHServer.hs+ ghc-options: -Wall -threaded -fno-warn-unused-do-bind+ if flag(darcs28)+ cpp-options: -DDARCS28+ build-depends: darcs > 2.8.1 && < 2.9 else- ghc-options: -Wall -threaded+ build-depends: darcs > 2.9 && < 2.10+ if flag(ssh)+ cpp-options: -DSSH_FLAG+ build-depends:+ ssh >= 0.2.6 executable darcsden-post-hook- hs-source-dirs: src-- main-is: PostHook.hs+ hs-source-dirs: src+ main-is: PostHook.hs+ ghc-options: -Wall -threaded -fno-warn-unused-do-bind - if impl(ghc >= 6.12)- ghc-options: -Wall -threaded -fno-warn-unused-do-bind+ if flag(darcs28)+ cpp-options: -DDARCS28+ build-depends: darcs > 2.8.1 && < 2.9 else- ghc-options: -Wall -threaded+ build-depends: darcs > 2.9 && < 2.10+ if flag(ssh)+ cpp-options: -DSSH_FLAG+ if flag(closing)+ cpp-options: -DCLOSING+ build-depends: pcre-light
src/PostHook.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} module Main where import Control.Monad (forM_)@@ -8,7 +8,9 @@ import System.Environment import System.FilePath import Text.XML.Light+#ifdef CLOSING import Text.Regex.PCRE.Light.Char8+#endif import DarcsDen.State.Comment import DarcsDen.State.Issue@@ -47,12 +49,17 @@ . head $ onlyElems xml +#ifdef CLOSING closing :: [(String, String, Int)] closing = catMaybes (map closeMatch names)+#endif mr <- getOwnerRepository (owner, repo) case mr of Just (Repository { rID = Just rid }) ->+#ifndef CLOSING+ return ()+#else forM_ closing $ \(e, name, num) -> do ma <- getUserByEmail (emailFrom e) mi <- getIssue rid num@@ -82,9 +89,10 @@ Nothing -> error ("unknown issue #" ++ show num ++ "; ignoring")-+#endif _ -> error ("unknown repository: " ++ owner ++ "/" ++ repo) where+#if CLOSING closeMatch (a, s) = case match (compile regex [caseless]) s [] of Just [_, _, n] -> Just (a, s, read n)@@ -93,6 +101,7 @@ _ -> Nothing regex = "(closes #([0-9]+)|resolves #([0-9]+)|fixes #([0-9]+))"+#endif nameAndAuthor e = case (ma, mn) of
src/SSHServer.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} module Main where +#ifndef SSH_FLAG+main :: IO ()+main = error "darcsden was not built with ssh support"+#else import Control.Monad.State-import Data.List (isPrefixOf)+import Data.List (isPrefixOf, stripPrefix) import Data.Time import SSH.Channel import SSH.Crypto@@ -14,6 +18,7 @@ import qualified Codec.Binary.Base64.String as Base64 import qualified SSH as SSH +import DarcsDen.Settings import DarcsDen.State.Repository import DarcsDen.State.User import DarcsDen.State.Util@@ -31,7 +36,7 @@ (p:_) -> return (fromIntegral (read p :: Int)) _ -> return 5022 - kp <- rsaKeyPairFromFile (userRoot </> ".ssh" </> "id_rsa")+ kp <- rsaKeyPairFromFile (homeDir </> ".ssh" </> "id_rsa") startSSH kp port where startSSH kp = SSH.start@@ -58,7 +63,7 @@ return False where rsaPrefix = "ssh-rsa"- dsaPrefix = "ssh-dsa"+ dsaPrefix = "ssh-dss" keyMatch :: String -> Session Bool keyMatch k =@@ -97,6 +102,7 @@ , rForkOf = Nothing , rMembers = [] , rIsPrivate = False+ , rIssueTracker = False , rIssueCount = 0 } finishWith "repository created"@@ -148,9 +154,9 @@ safePath :: FilePath -> (FilePath -> Channel ()) -> Channel () 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+ cp <- liftIO (canonicalizePath (usersDir </> un </> p))+ case stripPrefix (splitDirectories usersDir) $ takeWhile (not . null) . splitDirectories $ cp of+ Just (ownerName:repoName:_) -> do mrepo <- getOwnerRepository (ownerName, repoName) case mrepo of Just r | un `elem` (ownerName:rMembers r)->@@ -196,3 +202,4 @@ channelRequest wr r = do channelError $ "this server only accepts exec requests\r\ngot: " ++ show r when wr channelFail+#endif
src/WebServer.hs view
@@ -1,56 +1,36 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} module Main where +import Blaze.ByteString.Builder (fromByteString, toByteString)+import Blaze.ByteString.Builder.Char8 (fromShow)+-- #ifdef DEBUG+-- import Blaze.ByteString.Builder.Char8 (fromString)+-- #endif+import Control.Exception import Control.Monad (forM_) import Control.Monad.Trans import Database.CouchDB+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 (pack)+import Data.Monoid (mconcat)+import Snap.Core import Snap.Http.Server+import System.Directory (getCurrentDirectory) import System.Environment-import Text.JSON +-- import DarcsDen.Debug import DarcsDen.Handler-import DarcsDen.State.Util+import DarcsDen.Settings+import DarcsDen.State.Schema+import DarcsDen.State.Util (runDB, withRedis)+import DarcsDen.WebUtils (exceptionPage) main :: IO () main = do+ cwd <- liftIO getCurrentDirectory as <- getArgs case as of- ("--readme":_) ->- putStr . unlines $- [ "darcsden is a darcs hosting platform, providing a simple website and"- , "a SSH server for push/pull and quick repository creation."- , ""- , "You will need:"- , "- CouchDB, with the databases and views described below."- , "- Redis"- , ""- , "Both should be running on their default port, or just edit"- , "DarcsDen/State/Util.hs to point to different ones."- , ""- , ""- , "To install:"- , ""- , " cabal install"- , " mkdir -p /srv/darcs"- , " adduser --system --home /srv/darcs --no-create-home --shell /bin/bash --group --gecos DarcsDen darcsden"- , " ssh-keygen -- save to /srv/darcs/.ssh/id_rsa"- , " chown -R darcsden:darcsden /srv/darcs"- , ""- , " -- make sure CouchDB is running"- , " darcsden --install"- , ""- , ""- , "To start:"- , "This package provides separate executables for the web and SSH servers,"- , "`darcsden' and `darcsden-ssh', respectively. I recommend running them in"- , "screen as user 'darcsden'."- , ""- , "The web server should be started from the directory containing /public, or"- , "you can run it behind nginx or something that'll handle /public requests by"- , "pointing to that directory."- ]- ("--install":_) -> runDB $ do liftIO (putStrLn "creating databases...") @@ -77,33 +57,25 @@ liftIO (putStrLn "All set!") - ("--port":p:_) -> do+ [] -> do checkDBs- putStrLn $ "darcsden running on port " ++ p- startHTTP (read p)+ putStrLn "darcsden running on port 8900"+ startHTTP 8900 hostname cwd - [] -> do+ ("--port":p:_) -> do checkDBs- putStrLn "darcsden running on port 8080"- startHTTP 8080+ putStrLn $ "darcsden running on port " ++ p+ startHTTP (read p) hostname cwd _ -> putStr . unlines $ [ "usage:" , " darcsden --readme : figure out how to use this thing" , " darcsden --install : set up CouchDB databases"+ , " darcsden : start webserver with defaults" , " darcsden --port PORT : start webserver on given port"- , " darcsden : start webserver on port 8080" ] where- 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 ())@@ -111,88 +83,40 @@ putStrLn "checking redis..." withRedis (return ()) - repoDesigns =- [ jsobj- [ ("_id", jsstr "_design/repositories")- , ("language", jsstr "javascript")- , ("views", jsobj- [ ("by_owner_and_name", jsobj- [ ("map", jsstr "function(doc) {\n if (doc.owner && doc.name && !doc.is_private)\n emit([doc.owner, doc.name], doc);\n}")- ])-- , ("by_owner", jsobj- [ ("map", jsstr "function(doc) {\n if (doc.owner && !doc.is_private)\n emit(doc.owner, doc);\n}")- ])-- , ("by_fork", jsobj- [ ("map", jsstr "function(doc) {\n if (doc.fork_of.Just && !doc.is_private)\n emit(doc.fork_of.Just, doc);\n}")- ])-- , ("by_member", jsobj- [ ("map", jsstr "function(doc) {\n if (!doc.is_private)\n for (member in doc.members)\n emit(doc.members[member], doc._id);\n}")- ])- ])- ]-- , jsobj- [ ("_id", jsstr "_design/private")- , ("language", jsstr "javascript")- , ("views", jsobj- [ ("by_owner", jsobj- [ ("map", jsstr "function(doc) {\n emit(doc.owner, doc);\n}\n")- ])- , ("by_owner_and_name", jsobj- [ ("map", jsstr "function(doc) {\n if (doc.owner && doc.name)\n emit([doc.owner, doc.name], doc);\n}")- ])- , ("by_member", jsobj- [ ("map", jsstr "function(doc) {\n for (member in doc.members)\n emit(doc.members[member], [doc.owner, doc.name]);\n}")- ])- ])- ]- ]-- userDesigns =- [ jsobj- [ ("_id", jsstr "_design/users")- , ("language", jsstr "javascript")- , ("views", jsobj- [ ("by_email", jsobj- [ ("map", jsstr "function(doc) {\n if (doc.email)\n emit(doc.email, doc);\n}")- ])- , ("by_name", jsobj- [ ("map", jsstr "function(doc) {\n if (doc.name)\n emit(doc.name, doc);\n}")- ])- ])- ]- ]+ startHTTP p h d = httpServe (config p h) (handler d) - 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}")- ])- ])- ]- ]+ config p h+ = setAccessLog (ConfigFileLog $ accessLog)+ . setErrorLog (ConfigFileLog $ errorLog)+ . setPort p+ . setHostname (B8.pack h)+ . setDefaultTimeout maxRequestTime+ . setErrorHandler errorHandler+#ifdef DEBUG+ -- . setVerbose False+#endif+ $ defaultConfig - commentDesigns =- [ jsobj- [ ("_id", jsstr "_design/comments")- , ("language", jsstr "javascript")- , ("views", jsobj- [ ("by_issue", jsobj- [ ("map", jsstr "function(doc) {\n emit(doc.issue, doc);\n}")- ])- ])- ]- ]+errorHandler :: SomeException -> Snap ()+errorHandler e = do+ r <- getRequest+ logError $ errorLogMsg e r+ exceptionPage e - jsstr = JSString . toJSString- jsobj = JSObject . toJSObject+errorLogMsg :: SomeException -> Request -> B.ByteString+errorLogMsg e r =+ toByteString $ mconcat $+ [ fromByteString "During processing of request from "+ , fromByteString $ rqRemoteAddr r+ , fromByteString ":"+ , fromShow $ rqRemotePort r+ , fromByteString "\n"+ , fromByteString "Request handler threw an exception:\n"+ , fromShow e+-- #ifdef DEBUG+-- , fromByteString "Request:\n"+-- , fromString $ show r+-- , fromByteString "\n"+-- #endif+ ]