gitit-0.5: Gitit/State.hs
{-
Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{- Functions for maintaining user list and session state.
-}
module Gitit.State where
import qualified Data.Map as M
import System.Random (randomRIO)
import Data.Digest.Pure.SHA (sha512, showDigest)
import qualified Data.ByteString.Lazy.UTF8 as L (fromString)
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.Trans (MonadIO(), liftIO)
import Control.Monad (replicateM, liftM)
import Control.Exception (try, throwIO)
import Data.FileStore
import Gitit.MimeTypes (readMimeTypesFile)
import Data.List (intercalate)
import Data.Char (toLower)
import Text.XHtml (Html)
import qualified Text.StringTemplate as T
appstate :: IORef AppState
appstate = unsafePerformIO $ newIORef $ AppState { sessions = undefined
, users = undefined
, config = undefined
, filestore = undefined
, mimeMap = undefined
, cache = undefined
, template = undefined
, jsMath = undefined }
initializeAppState :: MonadIO m => Config -> M.Map String User -> T.StringTemplate String -> m ()
initializeAppState conf users' templ = do
mimeMapFromFile <- liftIO $ readMimeTypesFile (mimeTypesFile conf)
updateAppState $ \s -> s { sessions = Sessions M.empty
, users = users'
, config = conf
, filestore = case repository conf of
Git fs -> gitFileStore fs
Darcs fs -> darcsFileStore fs
, mimeMap = mimeMapFromFile
, cache = M.empty
, template = templ
, jsMath = False }
updateAppState :: MonadIO m => (AppState -> AppState) -> m ()
updateAppState fn = liftIO $! atomicModifyIORef appstate $ \st -> (fn st, ())
queryAppState :: MonadIO m => (AppState -> a) -> m a
queryAppState fn = liftIO $! readIORef appstate >>= return . fn
data Repository = Git FilePath
| Darcs FilePath
deriving (Read, Show)
data PageType = Markdown | RST
deriving (Read, Show)
-- | Data structure for information read from config file.
data Config = Config {
repository :: Repository, -- file store for pages
defaultPageType :: PageType, -- the default page markup type for this wiki
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,
mimeTypesFile :: FilePath -- path of file associating mime types with file extensions
} deriving (Read, Show)
defaultConfig :: Config
defaultConfig = Config {
repository = Git "wikidata",
defaultPageType = Markdown,
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 = "",
mimeTypesFile = "/etc/mime.types"
}
data CachedPage = CachedPage {
cpContents :: Html
, cpRevisionId :: RevisionId
} deriving Show
type SessionKey = Integer
data SessionData = SessionData {
sessionUser :: String
} deriving (Read,Show,Eq)
data Sessions a = Sessions {unsession::M.Map SessionKey a}
deriving (Read,Show,Eq)
-- Password salt hashedPassword
data Password = Password { pSalt :: String, pHashed :: String }
deriving (Read,Show,Eq)
data User = User {
uUsername :: String,
uPassword :: Password,
uEmail :: String
} deriving (Show,Read)
data AppState = AppState {
sessions :: Sessions SessionData,
users :: M.Map String User,
config :: Config,
filestore :: FileStore,
mimeMap :: M.Map String String,
cache :: M.Map String CachedPage,
template :: T.StringTemplate String,
jsMath :: Bool
}
lookupCache :: MonadIO m => String -> (Maybe RevisionId) -> m (Maybe CachedPage)
lookupCache file (Just revid) = do
c <- queryAppState cache
fs <- getFileStore
case M.lookup file c of
Just cp | idsMatch fs (cpRevisionId cp) revid ->
return $ Just cp
_ -> return Nothing
lookupCache file Nothing = do
fs <- getFileStore
latestRes <- liftIO $ try (latest fs file)
case latestRes of
Right latestid -> do
c <- queryAppState cache
case M.lookup file c of
Just cp | idsMatch fs (cpRevisionId cp) latestid ->
return $ Just cp
_ -> return Nothing
Left NotFound -> return Nothing
Left e -> liftIO $ throwIO e
cacheContents :: MonadIO m => String -> RevisionId -> Html -> m ()
cacheContents file revid contents = do
c <- queryAppState cache
let newpage = CachedPage { cpContents = contents
, cpRevisionId = revid }
let newcache = M.insert file newpage c
updateAppState $ \s -> s { cache = newcache }
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
authUser :: MonadIO m => String -> String -> m Bool
authUser name pass = do
users' <- queryAppState users
case M.lookup name users' of
Just u -> do
let salt = pSalt $ uPassword u
let hashed = pHashed $ uPassword u
return $ hashed == hashPassword salt pass
Nothing -> return False
isUser :: MonadIO m => String -> m Bool
isUser name = liftM (M.member name) $ queryAppState users
addUser :: MonadIO m => String -> User -> m ()
addUser uname user = updateAppState (\s -> s { users = M.insert uname user (users s) }) >>
liftIO writeUserFile
delUser :: MonadIO m => String -> m ()
delUser uname = updateAppState (\s -> s { users = M.delete uname (users s) }) >>
liftIO writeUserFile
writeUserFile :: IO ()
writeUserFile = do
conf <- getConfig
usrs <- queryAppState users
liftIO $ writeFile (userFile conf) $ "[" ++ intercalate "\n," (map show $ M.toList usrs) ++ "\n]"
getUser :: MonadIO m => String -> m (Maybe User)
getUser uname = liftM (M.lookup uname) $ queryAppState users
isSession :: MonadIO m => SessionKey -> m Bool
isSession key = liftM (M.member key . unsession) $ queryAppState sessions
setSession :: MonadIO m => SessionKey -> SessionData -> m ()
setSession key u = updateAppState $ \s -> s { sessions = Sessions . M.insert key u . unsession $ sessions s }
newSession :: MonadIO m => SessionData -> m SessionKey
newSession u = do
key <- liftIO $ randomRIO (0, 1000000000)
setSession key u
return key
delSession :: MonadIO m => SessionKey -> m ()
delSession key = updateAppState $ \s -> s { sessions = Sessions . M.delete key . unsession $ sessions s }
getSession :: MonadIO m => SessionKey -> m (Maybe SessionData)
getSession key = queryAppState $ M.lookup key . unsession . sessions
getConfig :: MonadIO m => m Config
getConfig = queryAppState config
getFileStore :: MonadIO m => m FileStore
getFileStore = queryAppState filestore
getMimeTypeForExtension :: MonadIO m => String -> m String
getMimeTypeForExtension ext = do
mimes <- queryAppState mimeMap
return $ case M.lookup (dropWhile (=='.') $ map toLower ext) mimes of
Nothing -> "application/octet-stream"
Just t -> t
getDefaultPageType :: MonadIO m => m PageType
getDefaultPageType = liftM defaultPageType (queryAppState config)