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
-> String
-> String
-> 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