Main-Is:
Main.hs
Other-Modules:
+ Rakka.Authorization
Rakka.Environment
Rakka.Page
Rakka.Resource
--- /dev/null
+module Rakka.Authorization
+ ( AuthDB
+ , mkAuthDB
+ , isValidPair
+ )
+ where
+
+import qualified Codec.Binary.Base64 as B64
+import qualified Codec.Binary.UTF8.String as UTF8
+import Control.Concurrent.STM
+import qualified Data.Digest.SHA1 as SHA1
+import Data.Map (Map)
+import qualified Data.Map as M hiding (Map)
+import Data.Maybe
+import Data.Word
+import Rakka.SystemConfig
+import System.Directory
+import System.FilePath
+import System.IO
+
+
+data AuthDB
+ = AuthDB {
+ adbFilePath :: !FilePath
+ , adbUserMap :: !(TVar UserMap)
+ , adbSyncRequest :: !(TVar Bool)
+ }
+
+
+type UserMap = Map String [Word8]
+
+
+mkAuthDB :: FilePath -> IO AuthDB
+mkAuthDB lsdir
+ = do let path = lsdir </> "authDB"
+ m <- newTVarIO =<< loadUserMap path
+ req <- newTVarIO False
+ return AuthDB {
+ adbFilePath = path
+ , adbUserMap = m
+ , adbSyncRequest = req
+ }
+
+
+isValidPair :: AuthDB -> String -> String -> IO Bool
+isValidPair adb name pass
+ = let hash = SHA1.hash (UTF8.encode pass)
+ in
+ atomically $ do m <- readTVar (adbUserMap adb)
+ return (M.lookup name m == Just hash)
+
+
+loadUserMap :: FilePath -> IO UserMap
+loadUserMap path
+ = do exist <- doesFileExist path
+ if exist then
+ readFile path
+ >>=
+ return . initMap . M.fromList . map decodePair . fromJust . deserializeStringPairs
+ else
+ return M.empty
+ where
+ decodePair :: (String, String) -> (String, [Word8])
+ decodePair (name, b64Hash)
+ = (UTF8.decodeString name, B64.decode b64Hash)
+
+ initMap :: UserMap -> UserMap
+ initMap m
+ | M.null m = let name = "root"
+ hash = SHA1.hash []
+ in
+ M.singleton name hash
+ | otherwise = m
import qualified Data.Map as M
import Network
import qualified Network.HTTP.Lucu.Config as LC
+import Rakka.Authorization
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
, envSysConf :: !SystemConfig
, envStorage :: !Storage
, envInterpTable :: !InterpTable
+ , envAuthDB :: !AuthDB
}
createRepository reposPath [] []
sysConf <- mkSystemConfig lucuConf repos
storage <- mkStorage lsdir repos (makeDraft' interpTable)
+ authDB <- mkAuthDB lsdir
return $ Environment {
envLocalStateDir = lsdir
, envSysConf = sysConf
, envStorage = storage
, envInterpTable = interpTable
+ , envAuthDB = authDB
}
where
makeDraft' :: InterpTable -> Page -> IO Document
import Control.Concurrent
import Control.Concurrent.STM
-import Control.Exception
import Control.Monad
import Data.Maybe
import Data.Set (Set)
import System.FilePath
import System.IO
import System.Log.Logger
-import System.Posix.Files
-import System.Posix.Types
-import System.Posix.IO
import Text.HyperEstraier hiding (WriteLock)
updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
-updateIndexRev revFile f = bracket acquireLock releaseLock update
+updateIndexRev revFile f = withFile revFile ReadWriteMode update
where
- acquireLock :: IO Fd
- acquireLock
- = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
- waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
- return fd
-
- releaseLock :: Fd -> IO ()
- releaseLock fd
- = setLock fd (Unlock, AbsoluteSeek, 0, 0)
-
- update :: Fd -> IO ()
- update fd
- = do fdSeek fd AbsoluteSeek 0
- size <- return . fromIntegral . fileSize =<< getFdStatus fd
- (revStr, gotSize) <- fdRead fd size
- when (size /= gotSize) $ fail ("read " ++ show gotSize ++
- " bytes but expected " ++ show size ++ " bytes")
-
- let rev = case revStr of
- "" -> 0
- _ -> read revStr
-
- rev' <- f rev
-
- let revStr' = show rev' ++ "\n"
- size' = fromIntegral $ length revStr'
-
- fdSeek fd AbsoluteSeek 0
- setFdSize fd 0
- wroteSize <- fdWrite fd revStr'
- when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
- " bytes but expected " ++ show size' ++ " bytes")
+ update :: Handle -> IO ()
+ update h = do eof <- hIsEOF h
+ rev <- if eof then
+ return 0
+ else
+ hGetLine h >>= return . read
+ rev' <- f rev
+ hSeek h AbsoluteSeek 0
+ hSetFileSize h 0
+ hPutStrLn h (show rev')