From df6079ca32f808d76c595e7953bff7a1dd46b10b Mon Sep 17 00:00:00 2001 From: pho Date: Sun, 17 Feb 2008 13:20:20 +0900 Subject: [PATCH] Use HsOpenSSL instead of Crypto darcs-hash:20080217042020-62b54-184042afd0575c185359ca62b0d1c19d58a8d2e8.gz --- Main.hs | 4 +++- Rakka.cabal | 13 +++++++------ Rakka/Authorization.hs | 29 +++++++++++++++-------------- Rakka/Page.hs | 9 +++++---- Rakka/Resource/Render.hs | 7 +++---- Rakka/Wiki/Engine.hs | 5 +++-- 6 files changed, 36 insertions(+), 31 deletions(-) diff --git a/Main.hs b/Main.hs index 81f41a5..fc3a1b0 100644 --- a/Main.hs +++ b/Main.hs @@ -4,6 +4,7 @@ import Data.List import Data.Maybe import Network import Network.HTTP.Lucu +import OpenSSL import Rakka.Environment import Rakka.Resource.CheckAuth import Rakka.Resource.Index @@ -104,7 +105,8 @@ printUsage = do putStrLn "Usage:" main :: IO () -main = withSubversion $ +main = withOpenSSL $ + withSubversion $ do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs when (not $ null errors) diff --git a/Rakka.cabal b/Rakka.cabal index b19ab47..1f8cea3 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -1,13 +1,14 @@ Name: Rakka Synopsis: Wiki engine with Subversion backend Description: - FIXME: write this + Rakka is a wiki engine with Subversion backend. Its syntax is + similar to MediaWiki. Version: 0.1 License: PublicDomain Author: PHO Maintainer: PHO Stability: experimental -Homepage: http://ccm.sherry.jp/Rakka/ +Homepage: http://rakka.cielonegro.org/ Category: Web Tested-With: GHC == 6.6.1 Cabal-Version: >= 1.2 @@ -57,10 +58,10 @@ Flag hardest-optimization Executable rakka Build-Depends: - Crypto, FileManip, HTTP, HUnit, HsHyperEstraier, HsSVN, Lucu, - base, bytestring, containers, dataenc, directory, utf8-string, - filepath, hslogger, hxt, magic, mtl, network, parsec, stm, - time, unix, zlib + FileManip, HTTP, HUnit, HsHyperEstraier, HsOpenSSL, HsSVN, + Lucu, base, bytestring, containers, dataenc, directory, + utf8-string, filepath, hslogger, hxt, magic, mtl, network, + parsec, stm, time, unix, zlib Main-Is: Main.hs Other-Modules: diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs index 04beaba..0f865c3 100644 --- a/Rakka/Authorization.hs +++ b/Rakka/Authorization.hs @@ -5,15 +5,15 @@ module Rakka.Authorization ) where -import qualified Codec.Binary.Base64 as B64 import qualified Codec.Binary.UTF8.String as UTF8 import Control.Concurrent.STM import Control.Monad.Trans -import Data.Digest.SHA2 +import qualified Data.ByteString as B import Data.Map (Map) import qualified Data.Map as M hiding (Map) import Data.Maybe -import Data.Word +import OpenSSL.EVP.Base64 +import OpenSSL.EVP.Digest import Rakka.SystemConfig import System.Directory import System.FilePath @@ -28,7 +28,7 @@ data AuthDB } -type UserMap = Map String [Word8] +type UserMap = Map String String mkAuthDB :: FilePath -> IO AuthDB @@ -45,10 +45,10 @@ mkAuthDB lsdir isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool isValidPair adb name pass - = let hash = toOctets $ sha256 $ UTF8.encode pass - in - liftIO $ atomically $ do m <- readTVar (adbUserMap adb) - return (M.lookup name m == Just hash) + = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1" + let hash = digestBS sha1 $ B.pack $ UTF8.encode pass + atomically $ do m <- readTVar (adbUserMap adb) + return (M.lookup name m == Just hash) loadUserMap :: FilePath -> IO UserMap @@ -60,16 +60,17 @@ loadUserMap path return . M.fromList . map decodePair . fromJust . deserializeStringPairs else return M.empty - return (initMap m) + sha1 <- return . fromJust =<< getDigestByName "SHA1" + return (initMap sha1 m) where - decodePair :: (String, String) -> (String, [Word8]) + decodePair :: (String, String) -> (String, String) decodePair (name, b64Hash) - = (UTF8.decodeString name, fromJust $ B64.decode b64Hash) + = (UTF8.decodeString name, decodeBase64 b64Hash) - initMap :: UserMap -> UserMap - initMap m + initMap :: Digest -> UserMap -> UserMap + initMap sha1 m | M.null m = let name = "root" - hash = toOctets $ sha256 ([] :: [Word8]) + hash = digest sha1 "" in M.singleton name hash | otherwise = m diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 5d7ef68..a9dbe4f 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -29,13 +29,13 @@ module Rakka.Page ) where -import qualified Codec.Binary.Base64 as B64 import qualified Codec.Binary.UTF8.String as UTF8 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy as L hiding (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Char import Data.Map (Map) import qualified Data.Map as M @@ -43,6 +43,7 @@ import Data.Maybe import Data.Time import Network.HTTP.Lucu hiding (redirect) import Network.URI hiding (fragment) +import OpenSSL.EVP.Base64 import Rakka.Utils import Rakka.W3CDateTime import Subversion.Types @@ -293,7 +294,7 @@ xmlizePage ) += ( if entityIsBinary page then ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ entityContent page) + += txt (L8.unpack $ encodeBase64LBS $ entityContent page) ) else ( eelem "textData" @@ -353,8 +354,8 @@ parseEntity let (isBinary, content) = case (textData, binaryData) of - (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text ) - (Nothing , Just binary) -> (True , L.pack $ fromJust $ B64.decode $ dropWhitespace binary) + (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text) + (Nothing , Just binary) -> (True , L8.pack $ decodeBase64 $ dropWhitespace binary) _ -> error "one of textData or binaryData is required" mimeType = if isBinary then diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index c25ca58..3823cb4 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -3,16 +3,15 @@ module Rakka.Resource.Render ) where -import qualified Codec.Binary.Base64 as B64 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList import Control.Monad.Trans -import qualified Data.ByteString.Lazy as Lazy (ByteString, pack) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) +import qualified Data.ByteString.Lazy as Lazy import Data.Maybe import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils +import OpenSSL.EVP.Base64 import Rakka.Environment import Rakka.Page import Rakka.Utils @@ -68,7 +67,7 @@ handleRender env name let (bin, cType) = case cTypeM of Just (MIMEType "application" "x-rakka-base64-stream" _) - -> let b = Lazy.pack $ fromJust $ B64.decode $ L8.unpack entity + -> let b = decodeBase64LBS entity in (b, guessMIMEType b) Just t diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index e3e49ee..dc3d4f1 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -8,17 +8,18 @@ module Rakka.Wiki.Engine ) where -import qualified Codec.Binary.Base64 as B64 import qualified Codec.Binary.UTF8.String as UTF8 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Network.HTTP.Lucu import Network.URI +import OpenSSL.EVP.Base64 import Rakka.Page import Rakka.Storage import Rakka.SystemConfig @@ -117,7 +118,7 @@ wikifyBin interpTable binToURI m b = nullURI { uriScheme = "data:" - , uriPath = show m ++ ";base64," ++ B64.encode (Lazy.unpack b) + , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b) } -- 2.40.0