    {-
    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 :: 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 :: 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 :: forall (m :: * -> *).
    MonadIO m =>
    (GititState -> GititState) -> m ()
    updateGititState GititState -> GititState
    fn = IO () -> m ()
    forall a. IO a -> m a
    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 :: forall (m :: * -> *) a. MonadIO m => (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 a. IO a -> m a
    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 a. IO a -> ServerPartT (ReaderT WikiState IO) a
    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 a. a -> IO a
    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 = 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 a. a -> ServerPartT (ReaderT WikiState IO) a
    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 a. a -> ServerPartT (ReaderT WikiState IO) a
    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 = M.insert uname user (users s) }) GititServerPart ()
    -> ServerPartT (ReaderT WikiState IO) Config
    -> ServerPartT (ReaderT WikiState IO) Config
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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 a b.
    ServerPartT (ReaderT WikiState IO) a
    -> (a -> ServerPartT (ReaderT WikiState IO) b)
    -> ServerPartT (ReaderT WikiState IO) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
      IO () -> GititServerPart ()
    forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
    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 = M.adjust (const user) uname (users s) }) GititServerPart ()
    -> ServerPartT (ReaderT WikiState IO) Config
    -> ServerPartT (ReaderT WikiState IO) Config
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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 a b.
    ServerPartT (ReaderT WikiState IO) a
    -> (a -> ServerPartT (ReaderT WikiState IO) b)
    -> ServerPartT (ReaderT WikiState IO) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
      IO () -> GititServerPart ()
    forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
    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 = M.delete uname (users s) }) GititServerPart ()
    -> ServerPartT (ReaderT WikiState IO) Config
    -> ServerPartT (ReaderT WikiState IO) Config
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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 a b.
    ServerPartT (ReaderT WikiState IO) a
    -> (a -> ServerPartT (ReaderT WikiState IO) b)
    -> ServerPartT (ReaderT WikiState IO) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
      IO () -> GititServerPart ()
    forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
    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 :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *).
    MonadIO m =>
    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 . M.insert key u . unsession $ sessions s }

    newSession :: MonadIO m => SessionData -> m SessionKey
    newSession :: forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
    newSession SessionData
    u = do
      SessionKey
    key <- IO SessionKey -> m SessionKey
    forall a. IO a -> m a
    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 a. a -> m a
    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 = (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 . M.delete key . unsession $ sessions s }

    getSession :: MonadIO m => SessionKey -> m (Maybe SessionData)
    getSession :: forall (m :: * -> *).
    MonadIO m =>
    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