Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'master' of git://github.com/jgm/gitit

  • Loading branch information...
commit ddb00ef55a67da9c7e5fa2b70286f85a239b90ca 2 parents 2daba9b + 1bc9242
@gwern gwern authored
View
5 .hgignore
@@ -0,0 +1,5 @@
+^dist$
+\.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$
+~$
+syntax: glob
+.\#*
View
19 Network/Gitit.hs
@@ -136,13 +136,15 @@ wiki conf = do
-- directory, which contains defaults
let staticHandler = withExpiresHeaders $
fileServeStrict' [] static `mplus` fileServeStrict' [] defaultStatic
- let handlers = [debugHandler | debugMode conf] ++ (authHandler conf : wikiHandlers)
+ let debugHandler' = msum [debugHandler | debugMode conf]
+ let handlers = debugHandler' `mplus` authHandler conf `mplus`
+ authenticate ForRead (msum wikiHandlers)
let fs = filestoreFromConfig conf
let ws = WikiState { wikiConfig = conf, wikiFileStore = fs }
if compressResponses conf
then compressedResponseFilter
else return ""
- staticHandler `mplus` runHandler ws (withUser conf $ msum handlers)
+ staticHandler `mplus` runHandler ws (withUser conf handlers)
-- | Like 'fileServeStrict', but if file is not found, fail instead of
-- returning a 404 error.
@@ -163,13 +165,12 @@ wikiHandlers =
[ -- redirect /wiki -> /wiki/ when gitit is being served at /wiki
-- so that relative wikilinks on the page will work properly:
guardBareBase >> getWikiBase >>= \b -> movedPermanently (b ++ "/") (toResponse ())
- , dir "_user" currentUser
, dir "_activity" showActivity
, dir "_go" goToPage
, dir "_search" searchResults
, dir "_upload" $ do guard =<< return . uploadsAllowed =<< getConfig
- msum [ methodOnly GET >> requireUser uploadForm
- , methodOnly POST >> requireUser uploadFile ]
+ msum [ methodOnly GET >> authenticate ForModify uploadForm
+ , methodOnly POST >> authenticate ForModify uploadFile ]
, dir "_random" $ methodOnly GET >> randomPage
, dir "_index" indexPage
, dir "_feed" feedHandler
@@ -182,22 +183,22 @@ wikiHandlers =
, dir "_history" $ msum
[ showPageHistory
, guardPath isSourceCode >> showFileHistory ]
- , dir "_edit" $ requireUser (unlessNoEdit editPage showPage)
+ , dir "_edit" $ authenticate ForModify (unlessNoEdit editPage showPage)
, dir "_diff" $ msum
[ showPageDiff
, guardPath isSourceCode >> showFileDiff ]
, dir "_discuss" discussPage
, dir "_delete" $ msum
[ methodOnly GET >>
- requireUser (unlessNoDelete confirmDelete showPage)
+ authenticate ForModify (unlessNoDelete confirmDelete showPage)
, methodOnly POST >>
- requireUser (unlessNoDelete deletePage showPage) ]
+ authenticate ForModify (unlessNoDelete deletePage showPage) ]
, dir "_preview" preview
, guardIndex >> indexPage
, guardCommand "export" >> exportPage
, methodOnly POST >> guardCommand "cancel" >> showPage
, methodOnly POST >> guardCommand "update" >>
- requireUser (unlessNoEdit updatePage showPage)
+ authenticate ForModify (unlessNoEdit updatePage showPage)
, showPage
, guardPath isSourceCode >> methodOnly GET >> showHighlightedSource
, handleAny
View
85 Network/Gitit/Authentication.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
Henry Laxen <nadine.and.henry@pobox.com>
@@ -20,7 +21,10 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
{- Handlers for registering and authenticating users.
-}
-module Network.Gitit.Authentication (formAuthHandlers, httpAuthHandlers, loginUserForm) where
+module Network.Gitit.Authentication ( loginUserForm
+ , formAuthHandlers
+ , httpAuthHandlers
+ , rpxAuthHandlers) where
import Network.Gitit.State
import Network.Gitit.Types
@@ -37,13 +41,17 @@ import Control.Monad.Trans (MonadIO(), liftIO)
import System.Exit
import System.Log.Logger (logM, Priority(..))
import Data.Char (isAlphaNum, isAlpha, isAscii)
+import qualified Data.Map as M
import Text.Pandoc.Shared (substitute)
-import Data.Maybe (isJust, fromJust)
+import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)
import Network.URL (encString, exportURL, add_param, importURL)
import Network.BSD (getHostName)
import qualified Text.StringTemplate as T
-import Network.HTTP (urlEncodeVars)
-import Codec.Binary.UTF8.String (encodeString)
+import Network.HTTP (urlEncodeVars, urlDecode, urlEncode)
+import Codec.Binary.UTF8.String (encodeString)
+import Data.ByteString.UTF8 (toString)
+import Network.Gitit.Rpxnow as R
+import Control.Monad.Reader (runReaderT, ask)
data ValidationType = Register
| ResetPassword
@@ -407,6 +415,7 @@ formAuthHandlers =
, dir "_resetPassword" $ methodSP POST $ withData resetPasswordRequest
, dir "_doResetPassword" $ methodSP GET $ withData resetPassword
, dir "_doResetPassword" $ methodSP POST $ withData doResetPassword
+ , dir "_user" currentUser
]
loginUserHTTP :: Params -> Handler
@@ -421,4 +430,70 @@ logoutUserHTTP = unauthorized $ toResponse () -- will this work?
httpAuthHandlers :: [Handler]
httpAuthHandlers =
[ dir "_logout" $ logoutUserHTTP
- , dir "_login" $ withData loginUserHTTP ]
+ , dir "_login" $ withData loginUserHTTP
+ , dir "_user" currentUser ]
+
+-- Login using RPX (see RPX development docs at https://rpxnow.com/docs)
+loginRPXUser :: RPars -- ^ The parameters passed by the RPX callback call (after authentication has taken place
+ -> Handler
+loginRPXUser params = do
+ cfg <- getConfig
+ ref <- getReferer
+ let mtoken = rToken params
+ if isNothing mtoken
+ then do
+ let url = baseUrl cfg ++ "/_login?destination=" ++
+ (fromMaybe ref $ rDestination params)
+ if null (rpxDomain cfg)
+ then error "rpx-domain is not set."
+ else do
+ let rpx = "https://" ++ rpxDomain cfg ++
+ ".rpxnow.com/openid/v2/signin?token_url=" ++
+ urlEncode url
+ see rpx
+ else do -- We got an answer from RPX, this might also return an exception.
+ uid' :: Either String R.Identifier <- liftIO $
+ R.authenticate (rpxKey cfg) $ fromJust mtoken
+ uid <- case uid' of
+ Right u -> return u
+ Left err -> error err
+ liftIO $ logM "gitit.loginRPXUser" DEBUG $ "uid:" ++ show uid
+ -- We need to get an unique identifier for the user
+ -- The 'identifier' is always present but can be rather cryptic
+ -- The 'verifiedEmail' is also unique and is a more readable choice
+ -- so we use it if present.
+ let userId = R.userIdentifier uid
+ let email = prop "verifiedEmail" uid
+ user <- liftIO $ mkUser (fromMaybe userId email) (fromMaybe "" email) "none"
+ updateGititState $ \s -> s { users = M.insert userId user (users s) }
+ key <- newSession (SessionData userId)
+ addCookie (sessionTimeout cfg) (mkCookie "sid" (show key))
+ see $ fromJust $ rDestination params
+ where
+ prop pname info = lookup pname $ R.userData info
+ see url = seeOther (encUrl url) $ toResponse noHtml
+
+-- The parameters passed by the RPX callback call.
+data RPars = RPars {rToken::Maybe String,rDestination::Maybe String} deriving Show
+
+instance FromData RPars where
+ fromData = do
+ let look' = liftM urlDecode . look
+ env <- ask
+ let vtoken = runReaderT (look "token") env
+ let vDestination = runReaderT (look' "destination") env
+ return RPars {rToken=vtoken,rDestination=vDestination}
+
+rpxAuthHandlers :: [Handler]
+rpxAuthHandlers =
+ [ dir "_logout" $ methodSP GET $ withData logoutUser
+ , dir "_login" $ withData loginRPXUser
+ , dir "_user" currentUser ]
+
+-- | Returns username of logged in user or null string if nobody logged in.
+currentUser :: Handler
+currentUser = do
+ req <- askRq
+ ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)
+
+
View
17 Network/Gitit/Config.hs
@@ -27,7 +27,7 @@ where
import Network.Gitit.Types
import Network.Gitit.Server (mimeTypes)
import Network.Gitit.Framework
-import Network.Gitit.Authentication (formAuthHandlers, httpAuthHandlers)
+import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers)
import Network.Gitit.Util (parsePageType, readFileUTF8)
import System.Log.Logger (logM, Priority(..))
import qualified Data.Map as M
@@ -66,6 +66,7 @@ extractConfig cp = do
cfDefaultPageType <- get cp "DEFAULT" "default-page-type"
cfMathMethod <- get cp "DEFAULT" "math"
cfShowLHSBirdTracks <- get cp "DEFAULT" "show-lhs-bird-tracks"
+ cfRequireAuthentication <- get cp "DEFAULT" "require-authentication"
cfAuthenticationMethod <- get cp "DEFAULT" "authentication-method"
cfUserFile <- get cp "DEFAULT" "user-file"
cfSessionTimeout <- get cp "DEFAULT" "session-timeout"
@@ -88,6 +89,8 @@ extractConfig cp = do
cfUseRecaptcha <- get cp "DEFAULT" "use-recaptcha"
cfRecaptchaPublicKey <- get cp "DEFAULT" "recaptcha-public-key"
cfRecaptchaPrivateKey <- get cp "DEFAULT" "recaptcha-private-key"
+ cfRPXDomain <- get cp "DEFAULT" "rpx-domain"
+ cfRPXKey <- get cp "DEFAULT" "rpx-key"
cfCompressResponses <- get cp "DEFAULT" "compress-responses"
cfUseCache <- get cp "DEFAULT" "use-cache"
cfCacheDir <- get cp "DEFAULT" "cache-dir"
@@ -115,6 +118,8 @@ extractConfig cp = do
"darcs" -> Darcs
"mercurial" -> Mercurial
x -> error $ "Unknown repository type: " ++ x
+ when (authMethod == "rpx" && cfRPXDomain == "") $
+ liftIO $ logM "gitit" WARNING $ "rpx-domain is not set"
return $! Config{
repositoryPath = cfRepositoryPath
@@ -130,10 +135,18 @@ extractConfig cp = do
, withUser = case authMethod of
"form" -> withUserFromSession
"http" -> withUserFromHTTPAuth
+ "rpx" -> withUserFromSession
_ -> id
+ , requireAuthentication = case map toLower cfRequireAuthentication of
+ "none" -> Never
+ "modify" -> ForModify
+ "read" -> ForRead
+ _ -> ForModify
+
, authHandler = case authMethod of
"form" -> msum formAuthHandlers
"http" -> msum httpAuthHandlers
+ "rpx" -> msum rpxAuthHandlers
_ -> mzero
, userFile = cfUserFile
, sessionTimeout = readNumber "session-timeout" cfSessionTimeout * 60 -- convert minutes -> seconds
@@ -162,6 +175,8 @@ extractConfig cp = do
, useRecaptcha = cfUseRecaptcha
, recaptchaPublicKey = cfRecaptchaPublicKey
, recaptchaPrivateKey = cfRecaptchaPrivateKey
+ , rpxDomain = cfRPXDomain
+ , rpxKey = cfRPXKey
, compressResponses = cfCompressResponses
, useCache = cfUseCache
, cacheDir = cfCacheDir
View
41 Network/Gitit/Framework.hs
@@ -21,8 +21,8 @@ module Network.Gitit.Framework (
-- * Combinators for dealing with users
withUserFromSession
, withUserFromHTTPAuth
- , requireUserThat
- , requireUser
+ , authenticateUserThat
+ , authenticate
, getLoggedInUser
-- * Combinators to exclude certain actions
, unlessNoEdit
@@ -75,24 +75,27 @@ import Network.URI (isUnescapedInURI)
import Happstack.Crypto.Base64 (decode)
import Network.HTTP (urlEncodeVars)
--- | Run the handler if a user is logged in, otherwise redirect
+-- | Require a logged in user if the authentication level demands it.
+-- Run the handler if a user is logged in, otherwise redirect
-- to login page.
-requireUser :: Handler -> Handler
-requireUser = requireUserThat (const True)
-
--- | Run the handler if a user satisfying the predicate is logged in.
--- Redirect to login if nobody logged in; raise error if someone is
--- logged in but doesn't satisfy the predicate.
-requireUserThat :: (User -> Bool) -> Handler -> Handler
-requireUserThat predicate handler = do
- mbUser <- getLoggedInUser
- rq <- askRq
- let url = rqUri rq ++ rqQuery rq
- case mbUser of
- Nothing -> tempRedirect ("/_login?" ++ urlEncodeVars [("destination", url)]) $ toResponse ()
- Just u -> if predicate u
- then handler
- else error "Not authorized."
+authenticate :: AuthenticationLevel -> Handler -> Handler
+authenticate = authenticateUserThat (const True)
+
+-- | Like 'authenticate', but with a predicate that the user must satisfy.
+authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
+authenticateUserThat predicate level handler = do
+ cfg <- getConfig
+ if level <= requireAuthentication cfg
+ then do
+ mbUser <- getLoggedInUser
+ rq <- askRq
+ let url = rqUri rq ++ rqQuery rq
+ case mbUser of
+ Nothing -> tempRedirect ("/_login?" ++ urlEncodeVars [("destination", url)]) $ toResponse ()
+ Just u -> if predicate u
+ then handler
+ else error "Not authorized."
+ else handler
-- | Run the handler after setting @REMOTE_USER@ with the user from
-- the session.
View
14 Network/Gitit/Handlers.hs
@@ -48,7 +48,6 @@ module Network.Gitit.Handlers (
, deletePage
, confirmDelete
, showHighlightedSource
- , currentUser
, expireCache
, feedHandler
)
@@ -65,7 +64,6 @@ import Network.Gitit.ContentTransformer (showRawPage, showFileAsText, showPage,
exportPage, showHighlightedSource, preview, applyPreCommitPlugins)
import Network.Gitit.Page (extractCategories)
import Control.Exception (throwIO, catch, try)
-import Data.ByteString.UTF8 (toString)
import System.Time
import System.FilePath
import Prelude hiding (catch)
@@ -192,7 +190,7 @@ uploadFile = withData $ \(params :: Params) -> do
cfg <- getConfig
mbUser <- getLoggedInUser
(user, email) <- case mbUser of
- Nothing -> fail "User must be logged in to delete page."
+ Nothing -> return ("Anonymous", "")
Just u -> return (uUsername u, uEmail u)
let overwrite = pOverwrite params
fs <- getFileStore
@@ -590,7 +588,7 @@ deletePage = withData $ \(params :: Params) -> do
let file = pFileToDelete params
mbUser <- getLoggedInUser
(user, email) <- case mbUser of
- Nothing -> fail "User must be logged in to delete."
+ Nothing -> return ("Anonymous", "")
Just u -> return (uUsername u, uEmail u)
let author = Author user email
let descrip = "Deleted using web interface."
@@ -608,7 +606,7 @@ updatePage = withData $ \(params :: Params) -> do
cfg <- getConfig
mbUser <- getLoggedInUser
(user, email) <- case mbUser of
- Nothing -> fail "User must be logged in to delete page."
+ Nothing -> return ("Anonymous", "")
Just u -> return (uUsername u, uEmail u)
editedText <- case pEditedText params of
Nothing -> error "No body text in POST request"
@@ -739,12 +737,6 @@ categoryListPage = do
pgScripts = ["search.js"],
pgTitle = "Categories" } htmlMatches
--- | Returns username of logged in user or null string if nobody logged in.
-currentUser :: Handler
-currentUser = do
- req <- askRq
- ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)
-
expireCache :: Handler
expireCache = do
page <- getPage
View
81 Network/Gitit/Rpxnow.hs
@@ -0,0 +1,81 @@
+-- Modified from Michael Snoyman's BSD3 authenticate-0.0.1
+-- and http-wget-0.0.1.
+-- Facilitates authentication with "http://rpxnow.com/".
+
+module Network.Gitit.Rpxnow
+ ( Identifier (..)
+ , authenticate
+ ) where
+
+import Text.JSON
+import Data.Maybe (isJust, fromJust)
+import System.Process
+import System.Exit
+import System.IO
+import Network.HTTP (urlEncodeVars)
+
+-- | Make a post request with parameters to the URL and return a response.
+curl :: Monad m
+ => String -- ^ URL
+ -> [(String, String)] -- ^ Post parameters
+ -> IO (m String) -- ^ Response body
+curl url params = do
+ (Nothing, Just hout, Just herr, phandle) <- createProcess $ (proc "curl"
+ [url, "-d", urlEncodeVars params]
+ ) { std_out = CreatePipe, std_err = CreatePipe }
+ exitCode <- waitForProcess phandle
+ case exitCode of
+ ExitSuccess -> hGetContents hout >>= return . return
+ _ -> hGetContents herr >>= return . fail
+
+
+
+-- | Information received from Rpxnow after a valid login.
+data Identifier = Identifier
+ { userIdentifier :: String
+ , userData :: [(String, String)]
+ }
+ deriving Show
+
+-- | Attempt to log a user in.
+authenticate :: Monad m
+ => String -- ^ API key given by RPXNOW.
+ -> String -- ^ Token passed by client.
+ -> IO (m Identifier)
+authenticate apiKey token = do
+ body <- curl
+ "https://rpxnow.com/api/v2/auth_info"
+ [ ("apiKey", apiKey)
+ , ("token", token)
+ ]
+ case body of
+ Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s
+ Right b ->
+ case decode b >>= getObject of
+ Error s -> return $ fail $ "Not a valid JSON response: " ++ s
+ Ok o ->
+ case valFromObj "stat" o of
+ Error _ -> return $ fail "Missing 'stat' field"
+ Ok "ok" -> return $ parseProfile o
+ Ok stat -> return $ fail $ "Login not accepted: " ++ stat
+
+parseProfile :: Monad m => JSObject JSValue -> m Identifier
+parseProfile v = do
+ profile <- resultToMonad $ valFromObj "profile" v >>= getObject
+ ident <- resultToMonad $ valFromObj "identifier" profile
+ let pairs = fromJSObject profile
+ pairs' = filter (\(k, _) -> k /= "identifier") pairs
+ pairs'' = map fromJust . filter isJust . map takeString $ pairs'
+ return $ Identifier ident pairs''
+
+takeString :: (String, JSValue) -> Maybe (String, String)
+takeString (k, JSString v) = Just (k, fromJSString v)
+takeString _ = Nothing
+
+getObject :: Monad m => JSValue -> m (JSObject JSValue)
+getObject (JSObject o) = return o
+getObject _ = fail "Not an object"
+
+resultToMonad :: Monad m => Result a -> m a
+resultToMonad (Ok x) = return x
+resultToMonad (Error s) = fail s
View
8 Network/Gitit/Types.hs
@@ -48,6 +48,9 @@ data FileStoreType = Git | Darcs | Mercurial deriving Show
data MathMethod = MathML | JsMathScript | WebTeX String | RawTeX
deriving (Read, Show, Eq)
+data AuthenticationLevel = Never | ForModify | ForRead
+ deriving (Read, Show, Eq, Ord)
+
-- | Data structure for information read from config file.
data Config = Config {
-- | Path of repository containing filestore
@@ -65,6 +68,8 @@ data Config = Config {
-- | Combinator to set @REMOTE_USER@ request header
withUser :: Handler -> Handler,
-- | Handler for login, logout, register, etc.
+ requireAuthentication :: AuthenticationLevel,
+ -- | Specifies which actions require authentication.
authHandler :: Handler,
-- | Path of users database
userFile :: FilePath,
@@ -108,6 +113,9 @@ data Config = Config {
useRecaptcha :: Bool,
recaptchaPublicKey :: String,
recaptchaPrivateKey :: String,
+ -- | RPX domain and key
+ rpxDomain :: String,
+ rpxKey :: String,
-- | Should responses be compressed?
compressResponses :: Bool,
-- | Should responses be cached?
View
25 data/default.conf
@@ -14,6 +14,12 @@ repository-path: wikidata
# specifies the path of the repository directory. If it does not
# exist, gitit will create it on startup.
+require-authentication: modify
+# if 'none', login is never required, and pages can be edited anonymously.
+# if 'modify', login is required to modify the wiki (edit, add, delete
+# pages, upload files).
+# if 'read', login is required to see any wiki pages.
+
authentication-method: form
# 'form' means that users will be logged in and registered
# using forms in the gitit web interface. 'http' means
@@ -24,7 +30,10 @@ authentication-method: form
# suppressed). 'generic' means that gitit will assume that
# some form of authentication is in place that directly
# sets REMOTE_USER to the name of the authenticated user
-# (e.g. mod_auth_cas on apache).
+# (e.g. mod_auth_cas on apache). 'rpx' means that gitit
+# will attempt to log in through https://rpxnow.com.
+# This requires that 'rpx-domain', 'rpx-key', and 'base-url'
+# be set below, and that 'curl' be in the system path.
user-file: gitit-users
# specifies the path of the file containing user login information.
@@ -170,6 +179,12 @@ access-question-answers:
# access-question: What is the code given to you by Ms. X?
# access-question-answers: RED DOG, red dog
+rpx-domain:
+rpx-key:
+# Specifies the domain and key of your RPX account. The domain is
+# just the prefix of the complete RPX domain, so if your full domain
+# is 'https://foo.rpxnow.com/', use 'foo' as the value of rpx-domain.
+
mail-command: sendmail %s
# specifies the command to use to send notification emails.
# '%s' will be replaced by the destination email address.
@@ -209,11 +224,9 @@ use-feed: no
# individual pages)
base-url:
-# the base URL of the wiki, to be used in constructing feed IDs.
-# If this field is left blank, gitit will get the base URL from the
-# request header 'Host'. For most users, this should be fine, but
-# if you are proxying a gitit instance to a subdirectory URL, you will
-# want to set this manually.
+# the base URL of the wiki, to be used in constructing feed IDs
+# and RPX token_urls. Set this if use-feed is 'yes' or
+# authentication-method is 'rpx'.
feed-days: 14
# number of days to be included in feeds.
View
1  data/static/css/screen.css
@@ -44,6 +44,7 @@ th { font-weight: bold; }
caption { margin-bottom: .5em; text-align: center; }
sup { vertical-align: super; }
sub { vertical-align: sub; }
+sub, sup { line-height: 0.3em; }
p, fieldset, table, pre { margin-bottom: 1em; }
button, input[type="checkbox"], input[type="radio"], input[type="reset"], input[type="submit"] { padding: 1px; }
View
10 gitit.cabal
@@ -91,11 +91,12 @@ Library
exposed-modules: Network.Gitit, Network.Gitit.ContentTransformer,
Network.Gitit.Types, Network.Gitit.Framework,
Network.Gitit.Initialize, Network.Gitit.Config,
- Network.Gitit.Layout
+ Network.Gitit.Layout, Network.Gitit.Authentication
other-modules: Network.Gitit.Cache, Network.Gitit.State,
Paths_gitit, Network.Gitit.Server, Network.Gitit.Export,
- Network.Gitit.Util, Network.Gitit.Handlers, Network.Gitit.Plugins,
- Network.Gitit.Authentication, Network.Gitit.Page, Network.Gitit.Feed
+ Network.Gitit.Util, Network.Gitit.Handlers,
+ Network.Gitit.Plugins, Network.Gitit.Rpxnow,
+ Network.Gitit.Page, Network.Gitit.Feed
if flag(plugins)
exposed-modules: Network.Gitit.Interface
build-depends: ghc, ghc-paths
@@ -144,7 +145,8 @@ Executable gitit
hslogger >= 1 && < 1.2,
ConfigFile >= 1 && < 1.1,
feed >= 0.3.6 && < 0.4,
- xss-sanitize >= 0.2 && < 0.3
+ xss-sanitize >= 0.2 && < 0.3,
+ json >= 0.4 && < 0.5
if impl(ghc >= 6.10)
build-depends: base >= 4, syb
if flag(plugins)
View
25 gitit.hs
@@ -32,6 +32,8 @@ import System.Environment
import System.Exit
import System.IO (stderr)
import System.Console.GetOpt
+import Network.Socket hiding (Debug)
+import Network.URI
import Data.Version (showVersion)
import qualified Data.ByteString as B
import Data.ByteString.UTF8 (fromString)
@@ -76,8 +78,15 @@ main = do
let serverConf = Conf { validator = Nothing, port = portNumber conf' }
+ -- open the requested interface
+ sock <- socket AF_INET Stream defaultProtocol
+ setSocketOption sock ReuseAddr 1
+ device <- inet_addr (getListenOrDefault opts)
+ bindSocket sock (SockAddrInet (toEnum (portNumber conf')) device)
+ listen sock 10
+
-- start the server
- simpleHTTP serverConf $ msum [ wiki conf'
+ simpleHTTPWithSocket sock serverConf $ msum [ wiki conf'
, dir "_reloadTemplates" reloadTemplates
]
@@ -85,6 +94,7 @@ data Opt
= Help
| ConfigFile FilePath
| Port Int
+ | Listen String
| Debug
| Version
| PrintDefaultConfig
@@ -98,6 +108,8 @@ flags =
"Print version information"
, Option ['p'] ["port"] (ReqArg (Port . read) "PORT")
"Specify port"
+ , Option ['l'] ["listen"] (ReqArg (Listen . checkListen) "INTERFACE")
+ "Specify interface to listen on"
, Option [] ["print-default-config"] (NoArg PrintDefaultConfig)
"Print default configuration"
, Option [] ["debug"] (NoArg Debug)
@@ -106,6 +118,16 @@ flags =
"Specify configuration file"
]
+checkListen :: String -> String
+checkListen l | isIPv6address l = l
+ | isIPv4address l = l
+ | otherwise = error "Gitit.checkListen: Not a valid interface name"
+
+getListenOrDefault :: [Opt] -> String
+getListenOrDefault [] = "127.0.0.1"
+getListenOrDefault ((Listen l):_) = l
+getListenOrDefault (_:os) = getListenOrDefault os
+
parseArgs :: [String] -> IO [Opt]
parseArgs argv = do
progname <- getProgName
@@ -139,6 +161,7 @@ handleFlag conf opt = do
Debug -> return conf{ debugMode = True }
Port p -> return conf{ portNumber = p }
ConfigFile fname -> getConfigFromFile fname
+ Listen _ -> return conf
putErr :: ExitCode -> String -> IO a
putErr c s = B.hPutStrLn stderr (fromString s) >> exitWith c
1  website
@@ -1 +0,0 @@
-Subproject commit 1fa9bf83c2e990feee7b173dc94aed067298c274
Please sign in to comment.
Something went wrong with that request. Please try again.