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

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

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

debugMessage :: String -> GititServerPart ()
debugMessage :: String -> GititServerPart ()
debugMessage String
msg = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
  forall (m :: * -> *) a. Monad m => a -> m a
return  User { uUsername :: String
uUsername = String
uname,
                 uPassword :: Password
uPassword = 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 = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
32 forall a b. (a -> b) -> a -> b
$ 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 = forall t. Digest t -> String
showDigest forall a b. (a -> b) -> a -> b
$ ByteString -> Digest SHA512State
sha512 forall a b. (a -> b) -> a -> b
$ String -> ByteString
L.fromString forall a b. (a -> b) -> a -> b
$ String
salt 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' <- forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Map String User
users
  case 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 forall a b. (a -> b) -> a -> b
$ User -> Password
uPassword User
u
         let hashed :: String
hashed = Password -> String
pHashed forall a b. (a -> b) -> a -> b
$ User -> Password
uPassword User
u
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
hashed forall a. Eq a => a -> a -> Bool
== String -> String -> String
hashPassword String
salt String
pass
       Maybe User
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isUser :: String -> GititServerPart Bool
isUser :: String -> GititServerPart Bool
isUser String
name = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall k a. Ord k => k -> Map k a -> Bool
M.member String
name) forall a b. (a -> b) -> a -> b
$ 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 =
  forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState (\GititState
s -> GititState
s { users :: Map String User
users = 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) }) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  ServerPartT (ReaderT WikiState IO) Config
getConfig forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState
  (\GititState
s -> GititState
s  { users :: Map String User
users = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (forall a b. a -> b -> a
const User
user) String
uname (GititState -> Map String User
users GititState
s) }) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  ServerPartT (ReaderT WikiState IO) Config
getConfig forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> IO ()
writeUserFile

delUser :: String -> GititServerPart ()
delUser :: String -> GititServerPart ()
delUser String
uname =
  forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState (\GititState
s -> GititState
s { users :: Map String User
users = forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
uname (GititState -> Map String User
users GititState
s) }) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  ServerPartT (ReaderT WikiState IO) Config
getConfig forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> Map String User
users
  forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SomeException -> IO ()
handleWriteError forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile (Config -> String
userFile Config
conf) forall a b. (a -> b) -> a -> b
$
      String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n," (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map String User
usrs) 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 forall a b. (a -> b) -> a -> b
$
               String
"Error writing user file " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Config -> String
userFile Config
conf) forall a. [a] -> [a] -> [a]
++
               String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e

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

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

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

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

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

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

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

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

getDefaultPageType :: GititServerPart PageType
getDefaultPageType :: GititServerPart PageType
getDefaultPageType = 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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Config -> Bool
defaultLHS ServerPartT (ReaderT WikiState IO) Config
getConfig