/
State.hs
140 lines (111 loc) · 4.86 KB
/
State.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
{-
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 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 qualified System.IO.Cautious as C (writeFile)
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 = unsafePerformIO $ newIORef GititState { sessions = undefined
, users = undefined
, templatesPath = 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
C.writeFile (userFile conf) $
"[" ++ intercalate "\n," (map show $ M.toList usrs) ++ "\n]"
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 $ 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