{-
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.Reader
import Data.FileStore
import Data.List (intercalate)
import System.Log.Logger (Priority(..), logM)
import Network.Gitit.Types

gititstate :: IORef GititState
gititstate :: IORef GititState
gititstate = IO (IORef GititState) -> IORef GititState
forall a. IO a -> a
unsafePerformIO (IO (IORef GititState) -> IORef GititState)
-> IO (IORef GititState) -> IORef GititState
forall a b. (a -> b) -> a -> b
$  GititState -> IO (IORef GititState)
forall a. a -> IO (IORef a)
newIORef  GititState :: Sessions SessionData
-> Map String User
-> String
-> (PageLayout -> Html -> Handler)
-> [Plugin]
-> GititState
GititState { sessions :: Sessions SessionData
sessions = Sessions SessionData
forall a. HasCallStack => a
undefined
                                                     , users :: Map String User
users = Map String User
forall a. HasCallStack => a
undefined
                                                     , templatesPath :: String
templatesPath = String
forall a. HasCallStack => a
undefined
                                                     , renderPage :: PageLayout -> Html -> Handler
renderPage = PageLayout -> Html -> Handler
forall a. HasCallStack => a
undefined
                                                     , plugins :: [Plugin]
plugins = [Plugin]
forall a. HasCallStack => a
undefined }

updateGititState :: MonadIO m => (GititState -> GititState) -> m ()
updateGititState :: (GititState -> GititState) -> m ()
updateGititState GititState -> GititState
fn = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$! IORef GititState -> (GititState -> (GititState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef GititState
gititstate ((GititState -> (GititState, ())) -> IO ())
-> (GititState -> (GititState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GititState
st -> (GititState -> GititState
fn GititState
st, ())

queryGititState :: MonadIO m => (GititState -> a) -> m a
queryGititState :: (GititState -> a) -> m a
queryGititState GititState -> a
fn = (GititState -> a) -> m GititState -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM GititState -> a
fn (m GititState -> m a) -> m GititState -> m a
forall a b. (a -> b) -> a -> b
$ IO GititState -> m GititState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GititState -> m GititState) -> IO GititState -> m GititState
forall a b. (a -> b) -> a -> b
$! IORef GititState -> IO GititState
forall a. IORef a -> IO a
readIORef IORef GititState
gititstate

debugMessage :: String -> GititServerPart ()
debugMessage :: String -> GititServerPart ()
debugMessage String
msg = IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ()) -> IO () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
DEBUG String
msg

mkUser :: String   -- username
       -> String   -- email
       -> String   -- unhashed password
       -> IO User
mkUser :: String -> String -> String -> IO User
mkUser String
uname String
email String
pass = do
  String
salt <- IO String
genSalt
  User -> IO User
forall (m :: * -> *) a. Monad m => a -> m a
return  User :: String -> Password -> String -> User
User { uUsername :: String
uUsername = String
uname,
                 uPassword :: Password
uPassword = Password :: String -> String -> Password
Password { pSalt :: String
pSalt = String
salt,
                                        pHashed :: String
pHashed = String -> String -> String
hashPassword String
salt String
pass },
                 uEmail :: String
uEmail = String
email }

genSalt :: IO String
genSalt :: IO String
genSalt = Int -> IO Char -> IO String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
32 (IO Char -> IO String) -> IO Char -> IO String
forall a b. (a -> b) -> a -> b
$ (Char, Char) -> IO Char
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Char
'0',Char
'z')

hashPassword :: String -> String -> String
hashPassword :: String -> String -> String
hashPassword String
salt String
pass = Digest SHA512State -> String
forall t. Digest t -> String
showDigest (Digest SHA512State -> String) -> Digest SHA512State -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Digest SHA512State
sha512 (ByteString -> Digest SHA512State)
-> ByteString -> Digest SHA512State
forall a b. (a -> b) -> a -> b
$ String -> ByteString
L.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
salt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pass

authUser :: String -> String -> GititServerPart Bool
authUser :: String -> String -> GititServerPart Bool
authUser String
name String
pass = do
  Map String User
users' <- (GititState -> Map String User)
-> ServerPartT (ReaderT WikiState IO) (Map String User)
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Map String User
users
  case String -> Map String User -> Maybe User
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name Map String User
users' of
       Just User
u  -> do
         let salt :: String
salt = Password -> String
pSalt (Password -> String) -> Password -> String
forall a b. (a -> b) -> a -> b
$ User -> Password
uPassword User
u
         let hashed :: String
hashed = Password -> String
pHashed (Password -> String) -> Password -> String
forall a b. (a -> b) -> a -> b
$ User -> Password
uPassword User
u
         Bool -> GititServerPart Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> GititServerPart Bool) -> Bool -> GititServerPart Bool
forall a b. (a -> b) -> a -> b
$ String
hashed String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> String
hashPassword String
salt String
pass
       Maybe User
Nothing -> Bool -> GititServerPart Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isUser :: String -> GititServerPart Bool
isUser :: String -> GititServerPart Bool
isUser String
name = (Map String User -> Bool)
-> ServerPartT (ReaderT WikiState IO) (Map String User)
-> GititServerPart Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Map String User -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member String
name) (ServerPartT (ReaderT WikiState IO) (Map String User)
 -> GititServerPart Bool)
-> ServerPartT (ReaderT WikiState IO) (Map String User)
-> GititServerPart Bool
forall a b. (a -> b) -> a -> b
$ (GititState -> Map String User)
-> ServerPartT (ReaderT WikiState IO) (Map String User)
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Map String User
users

addUser :: String -> User -> GititServerPart ()
addUser :: String -> User -> GititServerPart ()
addUser String
uname User
user =
  (GititState -> GititState) -> GititServerPart ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState (\GititState
s -> GititState
s { users :: Map String User
users = String -> User -> Map String User -> Map String User
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
uname User
user (GititState -> Map String User
users GititState
s) }) GititServerPart ()
-> ServerPartT (ReaderT WikiState IO) Config
-> ServerPartT (ReaderT WikiState IO) Config
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  ServerPartT (ReaderT WikiState IO) Config
getConfig ServerPartT (ReaderT WikiState IO) Config
-> (Config -> GititServerPart ()) -> GititServerPart ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ())
-> (Config -> IO ()) -> Config -> GititServerPart ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> IO ()
writeUserFile

adjustUser :: String -> User -> GititServerPart ()
adjustUser :: String -> User -> GititServerPart ()
adjustUser String
uname User
user = (GititState -> GititState) -> GititServerPart ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState
  (\GititState
s -> GititState
s  { users :: Map String User
users = (User -> User) -> String -> Map String User -> Map String User
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (User -> User -> User
forall a b. a -> b -> a
const User
user) String
uname (GititState -> Map String User
users GititState
s) }) GititServerPart ()
-> ServerPartT (ReaderT WikiState IO) Config
-> ServerPartT (ReaderT WikiState IO) Config
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  ServerPartT (ReaderT WikiState IO) Config
getConfig ServerPartT (ReaderT WikiState IO) Config
-> (Config -> GititServerPart ()) -> GititServerPart ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ())
-> (Config -> IO ()) -> Config -> GititServerPart ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> IO ()
writeUserFile

delUser :: String -> GititServerPart ()
delUser :: String -> GititServerPart ()
delUser String
uname =
  (GititState -> GititState) -> GititServerPart ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState (\GititState
s -> GititState
s { users :: Map String User
users = String -> Map String User -> Map String User
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
uname (GititState -> Map String User
users GititState
s) }) GititServerPart ()
-> ServerPartT (ReaderT WikiState IO) Config
-> ServerPartT (ReaderT WikiState IO) Config
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  ServerPartT (ReaderT WikiState IO) Config
getConfig ServerPartT (ReaderT WikiState IO) Config
-> (Config -> GititServerPart ()) -> GititServerPart ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ())
-> (Config -> IO ()) -> Config -> GititServerPart ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> IO ()
writeUserFile

writeUserFile :: Config -> IO ()
writeUserFile :: Config -> IO ()
writeUserFile Config
conf = do
  Map String User
usrs <- (GititState -> Map String User) -> IO (Map String User)
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Map String User
users
  (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SomeException -> IO ()
handleWriteError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile (Config -> String
userFile Config
conf) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n," (((String, User) -> String) -> [(String, User)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, User) -> String
forall a. Show a => a -> String
show ([(String, User)] -> [String]) -> [(String, User)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String User -> [(String, User)]
forall k a. Map k a -> [(k, a)]
M.toList Map String User
usrs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n]"
    where handleWriteError :: E.SomeException -> IO ()
          handleWriteError :: SomeException -> IO ()
handleWriteError SomeException
e = String -> Priority -> String -> IO ()
logM String
"gitit" Priority
ERROR (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
               String
"Error writing user file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Config -> String
userFile Config
conf) String -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e

getUser :: String -> GititServerPart (Maybe User)
getUser :: String -> GititServerPart (Maybe User)
getUser String
uname = (Map String User -> Maybe User)
-> ServerPartT (ReaderT WikiState IO) (Map String User)
-> GititServerPart (Maybe User)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Map String User -> Maybe User
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
uname) (ServerPartT (ReaderT WikiState IO) (Map String User)
 -> GititServerPart (Maybe User))
-> ServerPartT (ReaderT WikiState IO) (Map String User)
-> GititServerPart (Maybe User)
forall a b. (a -> b) -> a -> b
$ (GititState -> Map String User)
-> ServerPartT (ReaderT WikiState IO) (Map String User)
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Map String User
users

isSession :: MonadIO m => SessionKey -> m Bool
isSession :: SessionKey -> m Bool
isSession SessionKey
key = (Sessions SessionData -> Bool)
-> m (Sessions SessionData) -> m Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SessionKey -> Map SessionKey SessionData -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member SessionKey
key (Map SessionKey SessionData -> Bool)
-> (Sessions SessionData -> Map SessionKey SessionData)
-> Sessions SessionData
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sessions SessionData -> Map SessionKey SessionData
forall a. Sessions a -> Map SessionKey a
unsession) (m (Sessions SessionData) -> m Bool)
-> m (Sessions SessionData) -> m Bool
forall a b. (a -> b) -> a -> b
$ (GititState -> Sessions SessionData) -> m (Sessions SessionData)
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Sessions SessionData
sessions

setSession :: MonadIO m => SessionKey -> SessionData -> m ()
setSession :: SessionKey -> SessionData -> m ()
setSession SessionKey
key SessionData
u = (GititState -> GititState) -> m ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState ((GititState -> GititState) -> m ())
-> (GititState -> GititState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GititState
s ->
  GititState
s { sessions :: Sessions SessionData
sessions = Map SessionKey SessionData -> Sessions SessionData
forall a. Map SessionKey a -> Sessions a
Sessions (Map SessionKey SessionData -> Sessions SessionData)
-> (Sessions SessionData -> Map SessionKey SessionData)
-> Sessions SessionData
-> Sessions SessionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionKey
-> SessionData
-> Map SessionKey SessionData
-> Map SessionKey SessionData
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SessionKey
key SessionData
u (Map SessionKey SessionData -> Map SessionKey SessionData)
-> (Sessions SessionData -> Map SessionKey SessionData)
-> Sessions SessionData
-> Map SessionKey SessionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sessions SessionData -> Map SessionKey SessionData
forall a. Sessions a -> Map SessionKey a
unsession (Sessions SessionData -> Sessions SessionData)
-> Sessions SessionData -> Sessions SessionData
forall a b. (a -> b) -> a -> b
$ GititState -> Sessions SessionData
sessions GititState
s }

newSession :: MonadIO m => SessionData -> m SessionKey
newSession :: SessionData -> m SessionKey
newSession SessionData
u = do
  SessionKey
key <- IO SessionKey -> m SessionKey
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SessionKey -> m SessionKey) -> IO SessionKey -> m SessionKey
forall a b. (a -> b) -> a -> b
$ Integer -> SessionKey
SessionKey (Integer -> SessionKey) -> IO Integer -> IO SessionKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> IO Integer
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Integer
0, Integer
1000000000)
  SessionKey -> SessionData -> m ()
forall (m :: * -> *).
MonadIO m =>
SessionKey -> SessionData -> m ()
setSession SessionKey
key SessionData
u
  SessionKey -> m SessionKey
forall (m :: * -> *) a. Monad m => a -> m a
return SessionKey
key

delSession :: MonadIO m => SessionKey -> m ()
delSession :: SessionKey -> m ()
delSession SessionKey
key = (GititState -> GititState) -> m ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState ((GititState -> GititState) -> m ())
-> (GititState -> GititState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GititState
s ->
  GititState
s { sessions :: Sessions SessionData
sessions = Map SessionKey SessionData -> Sessions SessionData
forall a. Map SessionKey a -> Sessions a
Sessions (Map SessionKey SessionData -> Sessions SessionData)
-> (Sessions SessionData -> Map SessionKey SessionData)
-> Sessions SessionData
-> Sessions SessionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionKey
-> Map SessionKey SessionData -> Map SessionKey SessionData
forall k a. Ord k => k -> Map k a -> Map k a
M.delete SessionKey
key (Map SessionKey SessionData -> Map SessionKey SessionData)
-> (Sessions SessionData -> Map SessionKey SessionData)
-> Sessions SessionData
-> Map SessionKey SessionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sessions SessionData -> Map SessionKey SessionData
forall a. Sessions a -> Map SessionKey a
unsession (Sessions SessionData -> Sessions SessionData)
-> Sessions SessionData -> Sessions SessionData
forall a b. (a -> b) -> a -> b
$ GititState -> Sessions SessionData
sessions GititState
s }

getSession :: MonadIO m => SessionKey -> m (Maybe SessionData)
getSession :: SessionKey -> m (Maybe SessionData)
getSession SessionKey
key = (GititState -> Maybe SessionData) -> m (Maybe SessionData)
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState ((GititState -> Maybe SessionData) -> m (Maybe SessionData))
-> (GititState -> Maybe SessionData) -> m (Maybe SessionData)
forall a b. (a -> b) -> a -> b
$ SessionKey -> Map SessionKey SessionData -> Maybe SessionData
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SessionKey
key (Map SessionKey SessionData -> Maybe SessionData)
-> (GititState -> Map SessionKey SessionData)
-> GititState
-> Maybe SessionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sessions SessionData -> Map SessionKey SessionData
forall a. Sessions a -> Map SessionKey a
unsession (Sessions SessionData -> Map SessionKey SessionData)
-> (GititState -> Sessions SessionData)
-> GititState
-> Map SessionKey SessionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GititState -> Sessions SessionData
sessions

getConfig :: GititServerPart Config
getConfig :: ServerPartT (ReaderT WikiState IO) Config
getConfig = (WikiState -> Config)
-> ServerPartT (ReaderT WikiState IO) WikiState
-> ServerPartT (ReaderT WikiState IO) Config
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM WikiState -> Config
wikiConfig ServerPartT (ReaderT WikiState IO) WikiState
forall r (m :: * -> *). MonadReader r m => m r
ask

getFileStore :: GititServerPart FileStore
getFileStore :: GititServerPart FileStore
getFileStore = (WikiState -> FileStore)
-> ServerPartT (ReaderT WikiState IO) WikiState
-> GititServerPart FileStore
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM WikiState -> FileStore
wikiFileStore ServerPartT (ReaderT WikiState IO) WikiState
forall r (m :: * -> *). MonadReader r m => m r
ask

getDefaultPageType :: GititServerPart PageType
getDefaultPageType :: GititServerPart PageType
getDefaultPageType = (Config -> PageType)
-> ServerPartT (ReaderT WikiState IO) Config
-> GititServerPart PageType
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Config -> PageType
defaultPageType ServerPartT (ReaderT WikiState IO) Config
getConfig

getDefaultLHS :: GititServerPart Bool
getDefaultLHS :: GititServerPart Bool
getDefaultLHS = (Config -> Bool)
-> ServerPartT (ReaderT WikiState IO) Config
-> GititServerPart Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Config -> Bool
defaultLHS ServerPartT (ReaderT WikiState IO) Config
getConfig