gitit 0.3.4.2 → 0.4.1
raw patch · 5 files changed
+166/−82 lines, 5 filesdep +randomdep +recaptchadep ~network
Dependencies added: random, recaptcha
Dependency ranges changed: network
Files
- Gitit.hs +59/−19
- Gitit/State.hs +65/−31
- README.markdown +25/−17
- data/SampleConfig.hs +15/−13
- gitit.cabal +2/−2
Gitit.hs view
@@ -40,11 +40,9 @@ import Data.List (intersect, intersperse, intercalate, sort, nub, sortBy, isSuffixOf) import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) import Data.ByteString.UTF8 (fromString, toString)-import qualified Data.ByteString.Lazy.UTF8 as L (fromString) import Codec.Binary.UTF8.String (decodeString, encodeString) import qualified Data.Map as M import Data.Ord (comparing)-import Data.Digest.Pure.SHA (sha512, showDigest) import Paths_gitit import Text.Pandoc import Text.Pandoc.ODT (saveOpenDocumentAsODT)@@ -61,9 +59,11 @@ import Gitit.HStringTemplate (setAttribute) import Data.IORef import System.IO.Unsafe (unsafePerformIO)+import Network.Socket+import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) gititVersion :: String-gititVersion = "0.3.4.2"+gititVersion = "0.4.1" sessionTime :: Int sessionTime = 60 * 60 -- session will expire 1 hour after page request@@ -223,8 +223,11 @@ debugHandlers :: [Handler]-debugHandlers = [ withCommand "debug" [ handlePage GET $ \page params -> ok (toResponse $ show (page, params)),- handlePage POST $ \page params -> ok (toResponse $ show (page, params)) ] ]+debugHandlers = [ withCommand "params" [ handlePage GET $ \_ params -> ok (toResponse $ show params),+ handlePage POST $ \_ params -> ok (toResponse $ show params) ]+ , withCommand "page" [ handlePage GET $ \page _ -> ok (toResponse $ show page),+ handlePage POST $ \page _ -> ok (toResponse $ show page) ]+ , withCommand "request" [ withRequest $ \req -> ok $ toResponse $ show req ] ] wikiHandlers :: [Handler] wikiHandlers = [ handlePath "_index" GET indexPage@@ -257,6 +260,11 @@ , handlePage GET showPage ] +data Recaptcha = Recaptcha {+ recaptchaChallengeField :: String+ , recaptchaResponseField :: String+ } deriving (Read, Show)+ data Params = Params { pUsername :: String , pPassword :: String , pPassword2 :: String@@ -287,6 +295,8 @@ , pUser :: String , pConfirm :: Bool , pSessionKey :: Maybe SessionKey+ , pRecaptcha :: Recaptcha+ , pIPAddress :: String } deriving Show instance FromData Params where@@ -318,6 +328,8 @@ ac <- look "accessCode" `mplus` return "" cn <- (look "confirm" >> return True) `mplus` return False sk <- (readCookieValue "sid" >>= return . Just) `mplus` return Nothing+ rc <- look "recaptcha_challenge_field" `mplus` return ""+ rr <- look "recaptcha_response_field" `mplus` return "" return $ Params { pUsername = un , pPassword = pw , pPassword2 = p2@@ -348,6 +360,8 @@ , pUser = "" -- this gets set by ifLoggedIn... , pConfirm = cn , pSessionKey = sk+ , pRecaptcha = Recaptcha { recaptchaChallengeField = rc, recaptchaResponseField = rr }+ , pIPAddress = "" -- this gets set by handle... } getLoggedInUser :: MonadIO m => Params -> m (Maybe String)@@ -361,7 +375,7 @@ data Command = Command (Maybe String) commandList :: [String]-commandList = ["debug", "edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"]+commandList = ["page", "request", "params", "edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"] instance FromData Command where fromData = do@@ -406,13 +420,27 @@ then withData $ \params -> [ withRequest $ \req -> if rqMethod req == meth- then let referer = case M.lookup (fromString "referer") (rqHeaders req) of- Just r | not (null (hValue r)) -> Just $ toString $ head $ hValue r- _ -> Nothing- in responder path' (params { pReferer = referer, pUri = uri })+ then do+ let referer = case M.lookup (fromString "referer") (rqHeaders req) of+ Just r | not (null (hValue r)) -> Just $ toString $ head $ hValue r+ _ -> Nothing+ let peer = fst $ rqPeer req+ mbIPaddr <- liftIO $ lookupIPAddr peer+ let ipaddr = case mbIPaddr of+ Just ip -> ip+ Nothing -> "0.0.0.0"+ -- force ipaddr to be strictly evaluated, or we run into problems when validating captchas+ ipaddr `seq` responder path' (params { pReferer = referer, pUri = uri, pIPAddress = ipaddr }) else noHandle ] else anyRequest noHandle +lookupIPAddr :: String -> IO (Maybe String)+lookupIPAddr hostname = do+ addrs <- getAddrInfo (Just defaultHints) (Just hostname) Nothing+ if null addrs+ then return Nothing+ else return $ Just $ takeWhile (/=':') $ show $ addrAddress $ head addrs+ -- | Returns path portion of URI, without initial /. -- Consecutive spaces are collapsed. We don't want to distinguish 'Hi There' and 'Hi There'. uriPath :: String -> String@@ -968,9 +996,7 @@ let uname = pUsername params let pword = pPassword params let destination = pDestination params- cfg <- query GetConfig- let passwordHash = showDigest $ sha512 $ L.fromString $ passwordSalt cfg ++ pword- allowed <- query $ AuthUser uname passwordHash+ allowed <- query $ AuthUser uname pword if allowed then do key <- update $ NewSession (SessionData uname)@@ -998,6 +1024,9 @@ Nothing -> noHtml Just (prompt, _) -> label << prompt +++ br +++ X.password "accessCode" ! [size "15"] +++ br+ let captcha = if useRecaptcha cfg+ then captchaFields (recaptchaPublicKey cfg) Nothing+ else noHtml return $ gui "" ! [identifier "loginForm"] << fieldset << [ accessQ , label << "Username (at least 3 letters or digits):", br@@ -1008,6 +1037,7 @@ , label << "Password (at least 6 characters, including at least one non-letter):", br , X.password "password" ! [size "20"], stringToHtml " ", br , label << "Confirm Password:", br, X.password "password2" ! [size "20"], stringToHtml " ", br+ , captcha , submit "register" "Register" ] registerUserForm :: String -> Params -> Web Response@@ -1018,8 +1048,6 @@ registerUser :: String -> Params -> Web Response registerUser _ params = do- let page = "_register"- regForm <- registerForm let isValidUsername u = length u >= 3 && all isAlphaNum u let isValidPassword pw = length pw >= 6 && not (all isAlpha pw) let accessCode = pAccessCode params@@ -1028,26 +1056,38 @@ let pword2 = pPassword2 params let email = pEmail params let fakeField = pFullName params+ let recaptcha = pRecaptcha params taken <- query $ IsUser uname cfg <- query GetConfig let isValidAccessCode = case accessQuestion cfg of Nothing -> True Just (_, answers) -> accessCode `elem` answers let isValidEmail e = length (filter (=='@') e) == 1+ captchaResult <- if useRecaptcha cfg+ then if null (recaptchaChallengeField recaptcha) || null (recaptchaResponseField recaptcha)+ then return $ Left "missing-challenge-or-response" -- no need to bother captcha.net in this case+ else liftIO $ validateCaptcha (recaptchaPrivateKey cfg) (pIPAddress params) (recaptchaChallengeField recaptcha)+ (recaptchaResponseField recaptcha)+ else return $ Right ()+ let (validCaptcha, captchaError) = case captchaResult of+ Right () -> (True, Nothing)+ Left err -> (False, Just err) let errors = validate [ (taken, "Sorry, that username is already taken.") , (not isValidAccessCode, "Incorrect response to access prompt.") , (not (isValidUsername uname), "Username must be at least 3 charcaters, all letters or digits.") , (not (isValidPassword pword), "Password must be at least 6 characters, with at least one non-letter.") , (not (null email) && not (isValidEmail email), "Email address appears invalid.") , (pword /= pword2, "Password does not match confirmation.")+ , (not validCaptcha, "Failed CAPTCHA (" ++ fromJust captchaError ++ "). Are you really human?") , (not (null fakeField), "You do not seem human enough.") ] -- fakeField is hidden in CSS (honeypot) if null errors then do- let passwordHash = showDigest $ sha512 $ L.fromString $ passwordSalt cfg ++ pword- update $ AddUser uname (User { uUsername = uname, uPassword = passwordHash, uEmail = email })+ user <- liftIO $ mkUser uname email pword+ update $ AddUser uname user loginUser "/" (params { pUsername = uname, pPassword = pword, pEmail = email })- else formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) - page (params { pMessages = errors }) regForm+ else registerForm >>=+ formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" })+ "_register" (params { pMessages = errors }) showHighlightedSource :: String -> Params -> Web Response showHighlightedSource file params = do
Gitit/State.hs view
@@ -22,7 +22,8 @@ {- Functions for maintaining user list and session state. Parts of this code are based on http://hpaste.org/5957 mightybyte rev by - dbpatterson -}+ dbpatterson.+-} module Gitit.State where @@ -33,41 +34,48 @@ import HAppS.State import HAppS.Data import GHC.Conc (STM)+import System.Random (randomRIO)+import Data.Digest.Pure.SHA (sha512, showDigest)+import qualified Data.ByteString.Lazy.UTF8 as L (fromString) -- | Data structure for information read from config file. data Config = Config {- repositoryPath :: FilePath, -- path of git repository for pages- userFile :: FilePath, -- path of users database - templateFile :: FilePath, -- path of page template file- staticDir :: FilePath, -- path of static directory- tableOfContents :: Bool, -- should each page have an automatic table of contents?- maxUploadSize :: Integer, -- maximum size of pages and file uploads- portNumber :: Int, -- port number to serve content on- passwordSalt :: String, -- text to serve as salt in encrypting passwords- debugMode :: Bool, -- should debug info be printed to the console?- frontPage :: String, -- the front page of the wiki- noEdit :: [String], -- pages that cannot be edited through the web interface- noDelete :: [String], -- pages that cannot be deleted through the web interface- accessQuestion :: Maybe (String, [String]) -- if Nothing, then anyone can register for an account.- -- if Just (prompt, answers), then a user will be given the prompt- -- and must give one of the answers in order to register.+ repositoryPath :: FilePath, -- path of git repository for pages+ userFile :: FilePath, -- path of users database + templateFile :: FilePath, -- path of page template file+ staticDir :: FilePath, -- path of static directory+ tableOfContents :: Bool, -- should each page have an automatic table of contents?+ maxUploadSize :: Integer, -- maximum size of pages and file uploads+ portNumber :: Int, -- port number to serve content on+ debugMode :: Bool, -- should debug info be printed to the console?+ frontPage :: String, -- the front page of the wiki+ noEdit :: [String], -- pages that cannot be edited through the web interface+ noDelete :: [String], -- pages that cannot be deleted through the web interface+ accessQuestion :: Maybe (String, [String]), -- if Nothing, then anyone can register for an account.+ -- if Just (prompt, answers), then a user will be given the prompt+ -- and must give one of the answers in order to register.+ useRecaptcha :: Bool, -- use ReCAPTCHA service to provide captchas for user registration.+ recaptchaPublicKey :: String,+ recaptchaPrivateKey :: String } deriving (Read, Show,Eq,Typeable,Data) defaultConfig :: Config defaultConfig = Config {- repositoryPath = "wikidata",- userFile = "gitit-users",- templateFile = "template.html",- staticDir = "static",- tableOfContents = True,- maxUploadSize = 100000,- portNumber = 5001,- passwordSalt = "l91snthoae8eou2340987",- debugMode = False,- frontPage = "Front Page",- noEdit = ["Help"],- noDelete = ["Help", "Front Page"],- accessQuestion = Nothing+ repositoryPath = "wikidata",+ userFile = "gitit-users",+ templateFile = "template.html",+ staticDir = "static",+ tableOfContents = True,+ maxUploadSize = 100000,+ portNumber = 5001,+ debugMode = False,+ frontPage = "Front Page",+ noEdit = ["Help"],+ noDelete = ["Help", "Front Page"],+ accessQuestion = Nothing,+ useRecaptcha = False,+ recaptchaPublicKey = "",+ recaptchaPrivateKey = "" } type SessionKey = Integer@@ -79,9 +87,13 @@ data Sessions a = Sessions {unsession::M.Map SessionKey a} deriving (Read,Show,Eq,Typeable,Data) +-- Password salt hashedPassword+data Password = Password { pSalt :: String, pHashed :: String }+ deriving (Read,Show,Eq,Typeable,Data)+ data User = User { uUsername :: String,- uPassword :: String, -- password stored as SHA512 hash+ uPassword :: Password, uEmail :: String } deriving (Show,Read,Typeable,Data) @@ -101,7 +113,9 @@ instance Version AppState instance Version User+instance Version Password +$(deriveSerialize ''Password) $(deriveSerialize ''User) $(deriveSerialize ''AppState) @@ -127,6 +141,23 @@ isUser :: MonadReader AppState m => String -> m Bool isUser name = liftM (M.member name) askUsers +mkUser :: String -- username+ -> String -- email+ -> String -- unhashed password+ -> IO User+mkUser uname email pass = do+ salt <- genSalt+ return $ User { uUsername = uname,+ uPassword = Password { pSalt = salt, pHashed = hashPassword salt pass },+ uEmail = email }++genSalt :: IO String+genSalt =+ replicateM 32 $ randomRIO ('0','z')++hashPassword :: String -> String -> String+hashPassword salt pass = showDigest $ sha512 $ L.fromString $ salt ++ pass+ addUser :: MonadState AppState m => String -> User -> m () addUser name u = modUsers $ M.insert name u @@ -137,7 +168,10 @@ authUser name pass = do users' <- askUsers case M.lookup name users' of- Just u -> return $ pass == uPassword u+ Just u -> do+ let salt = pSalt $ uPassword u+ let hashed = pHashed $ uPassword u+ return $ hashed == hashPassword salt pass Nothing -> return False listUsers :: MonadReader AppState m => m [String]
README.markdown view
@@ -93,19 +93,21 @@ option `-f [filename]`. A configuration file takes the following form: Config {- repositoryPath = "wikidata",- userFile = "gitit-users",- templateFile = "template.html",- staticDir = "static",- tableOfContents = False,- maxUploadSize = 100000,- portNumber = 5001,- passwordSalt = "l91snthoae8eou2340987",- debugMode = True,- frontPage = "Front Page",- noEdit = ["Help", "Front Page"],- noDelete = ["Help", "Front Page"],- accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"])+ repositoryPath = "wikidata",+ userFile = "gitit-users",+ templateFile = "template.html",+ staticDir = "static",+ tableOfContents = False,+ maxUploadSize = 100000,+ portNumber = 5001,+ debugMode = True,+ frontPage = "Front Page",+ noEdit = ["Help", "Front Page"],+ noDelete = ["Help", "Front Page"],+ accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]),+ useRecaptcha = False,+ recaptchaPublicKey = "",+ recaptchaPrivateKey = "" } - `repositoryPath` is the (relative) path of the git repository in which@@ -133,10 +135,6 @@ - `portNumber` is the number of the port on which the wiki will be served. -- `passwordSalt` is used to hash the passwords in the user database;- you should change this to something unique if you use gitit in a- production setting.- - `debugMode` is either `True` or `False`. If it is `True`, debug information will be printed to the console when gitit is running. @@ -153,6 +151,16 @@ that will be displayed when a user tries to create an account, and `answer1, answer2, ...` are the valid responses. The user must provide a valid response in order to create an account. ++- `useRecaptcha` is either `True` or `False`. It specifies whether to+ use the [reCAPTCHA] service to provide captchas for user registration.++- `recaptchaPublicKey` and `recaptchaPrivateKey` are+ [reCAPTCHA] keys, which can be obtained free of charge at+ <http://recaptcha.net/api/getkey>. The values of these fields are ignored+ if `useRecaptcha` is set to `False`.++[reCAPTCHA]: http://recaptcha.net Configuring gitit =================
data/SampleConfig.hs view
@@ -1,16 +1,18 @@ Config {-repositoryPath = "wikidata",-userFile = "gitit-users",-templateFile = "template.html",-staticDir = "static",-tableOfContents = False,-maxUploadSize = 100000,-portNumber = 5001,-passwordSalt = "l91snthoae8eou2340987",-debugMode = True,-frontPage = "Front Page",-noEdit = ["Help", "Front Page"],-noDelete = ["Help", "Front Page"],-accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"])+repositoryPath = "wikidata",+userFile = "gitit-users",+templateFile = "template.html",+staticDir = "static",+tableOfContents = False,+maxUploadSize = 100000,+portNumber = 5001,+debugMode = True,+frontPage = "Front Page",+noEdit = ["Help", "Front Page"],+noDelete = ["Help", "Front Page"],+accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]),+useRecaptcha = False,+recaptchaPublicKey = "",+recaptchaPrivateKey = "" }
gitit.cabal view
@@ -1,5 +1,5 @@ name: gitit-version: 0.3.4.2+version: 0.4.1 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc.@@ -50,7 +50,7 @@ utf8-string, HAppS-Server >= 0.9.3 && < 0.9.4, HAppS-State >= 0.9.3 && < 0.9.4, HAppS-Data >= 0.9.3 && < 0.9.4, SHA > 1, HTTP,- HStringTemplate+ HStringTemplate, random, network >= 2.1.0.0, recaptcha >= 0.1 if impl(ghc >= 6.10) build-depends: base >= 4, syb ghc-options: -Wall -threaded