content: {-
  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 Network.Gitit.State where
  
  import qualified Control.Exception as E
  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 (liftM, replicateM)
  import Control.Monad.IO.Class
  import Control.Monad.Reader
  import Data.FileStore
  import Data.List (intercalate)
  import System.Log.Logger (Priority(..), logM)
  import Network.Gitit.Types
  
  gititstate :: IORef GititState
  gititstate = unsafePerformIO $  newIORef  GititState { sessions = undefined
                                                       , users = undefined
                                                       , renderPage = undefined
                                                       , plugins = undefined }
  
  updateGititState :: MonadIO m => (GititState -> GititState) -> m ()
  updateGititState fn = liftIO $! atomicModifyIORef gititstate $ \st -> (fn st, ())
  
  queryGititState :: MonadIO m => (GititState -> a) -> m a
  queryGititState fn = liftM fn $ liftIO $! readIORef gititstate
  
  debugMessage :: String -> GititServerPart ()
  debugMessage msg = liftIO $ logM "gitit" DEBUG msg
  
  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 :: String -> String -> GititServerPart Bool
  authUser name pass = do
    users' <- queryGititState 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 :: String -> GititServerPart Bool
  isUser name = liftM (M.member name) $ queryGititState users
  
  addUser :: String -> User -> GititServerPart ()
  addUser uname user =
    updateGititState (\s -> s { users = M.insert uname user (users s) }) >>
    getConfig >>=
    liftIO . writeUserFile
  
  adjustUser :: String -> User -> GititServerPart ()
  adjustUser uname user = updateGititState
    (\s -> s  { users = M.adjust (const user) uname (users s) }) >>
    getConfig >>=
    liftIO . writeUserFile
  
  delUser :: String -> GititServerPart ()
  delUser uname =
    updateGititState (\s -> s { users = M.delete uname (users s) }) >>
    getConfig >>=
    liftIO . writeUserFile
  
  writeUserFile :: Config -> IO ()
  writeUserFile conf = do
    usrs <- queryGititState users
    E.handle handleWriteError $ writeFile (userFile conf) $
        "[" ++ intercalate "\n," (map show $ M.toList usrs) ++ "\n]"
      where handleWriteError :: E.SomeException -> IO ()
            handleWriteError e = logM "gitit" ERROR $
                 "Error writing user file " ++ show (userFile conf) ++
                 "\n" ++ show e
  
  getUser :: String -> GititServerPart (Maybe User)
  getUser uname = liftM (M.lookup uname) $ queryGititState users
  
  isSession :: MonadIO m => SessionKey -> m Bool
  isSession key = liftM (M.member key . unsession) $ queryGititState sessions
  
  setSession :: MonadIO m => SessionKey -> SessionData -> m ()
  setSession key u = updateGititState $ \s ->
    s { sessions = Sessions . M.insert key u . unsession $ sessions s }
  
  newSession :: MonadIO m => SessionData -> m SessionKey
  newSession u = do
    key <- liftIO $ SessionKey <$> randomRIO (0, 1000000000)
    setSession key u
    return key
  
  delSession :: MonadIO m => SessionKey -> m ()
  delSession key = updateGititState $ \s ->
    s { sessions = Sessions . M.delete key . unsession $ sessions s }
  
  getSession :: MonadIO m => SessionKey -> m (Maybe SessionData)
  getSession key = queryGititState $ M.lookup key . unsession . sessions
  
  getConfig :: GititServerPart Config
  getConfig = liftM wikiConfig ask
  
  getFileStore :: GititServerPart FileStore
  getFileStore = liftM wikiFileStore ask
  
  getDefaultPageType :: GititServerPart PageType
  getDefaultPageType = liftM defaultPageType getConfig
  
  getDefaultLHS :: GititServerPart Bool
  getDefaultLHS = liftM defaultLHS getConfig
  