diff --git a/darcsden.cabal b/darcsden.cabal --- a/darcsden.cabal +++ b/darcsden.cabal @@ -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 +maintainer: Alex Suraci , Simon Michael +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 diff --git a/src/PostHook.hs b/src/PostHook.hs --- a/src/PostHook.hs +++ b/src/PostHook.hs @@ -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 diff --git a/src/SSHServer.hs b/src/SSHServer.hs --- a/src/SSHServer.hs +++ b/src/SSHServer.hs @@ -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 diff --git a/src/WebServer.hs b/src/WebServer.hs --- a/src/WebServer.hs +++ b/src/WebServer.hs @@ -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 + ]