X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FAuthorization.hs;fp=Rakka%2FAuthorization.hs;h=4ba4f12fb24c1f000bd8373d64213d678569d85f;hp=97927c5e1252b855784df2c6528da73043d142cd;hb=42f51754dea02201aececaacbf194d714cd58aaf;hpb=98fd1cb53a837a9bda7145544c34872acb13a634

diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
index 97927c5..4ba4f12 100644
--- a/Rakka/Authorization.hs
+++ b/Rakka/Authorization.hs
@@ -1,3 +1,8 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}
+-- FIXME: authentication
 module Rakka.Authorization
     ( AuthDB
     , mkAuthDB
@@ -7,31 +12,30 @@ module Rakka.Authorization
     , delUser
     )
     where
-
-import qualified Codec.Binary.UTF8.String as UTF8
+import Control.Applicative
 import           Control.Concurrent.STM
-import           Control.Monad
 import           Control.Monad.Trans
-import qualified Data.ByteString as B
+import Data.ByteString (ByteString)
 import           Data.Map (Map)
 import qualified Data.Map as M hiding (Map)
 import           Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
 import           OpenSSL.EVP.Base64
 import           OpenSSL.EVP.Digest
+import Prelude.Unicode
 import           Rakka.SystemConfig
 import           System.Directory
 import           System.FilePath
 
-
 data AuthDB
     = AuthDB {
-        adbFilePath    :: !FilePath
-      , adbUserMap     :: !(TVar UserMap)
+        adbFilePath ∷ !FilePath
+      , adbUserMap  ∷ !(TVar UserMap)
       }
 
-
-type UserMap = Map String String
-
+type UserMap = Map Text ByteString
 
 mkAuthDB :: FilePath -> IO AuthDB
 mkAuthDB lsdir
@@ -43,72 +47,55 @@ mkAuthDB lsdir
                     }
 
 
-isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
+isValidPair ∷ MonadIO m ⇒ AuthDB → Text → Text → m Bool
 isValidPair adb name pass
-    = 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)
-
-
-getUserList :: MonadIO m => AuthDB -> m [String]
-getUserList adb
-    = liftIO $
-      atomically $
-      do m <- readTVar (adbUserMap adb)
-	 return (M.keys m)
+    = liftIO $ do sha1 ← fromJust <$> getDigestByName "SHA1"
+                  let hash = digestBS' sha1 $ T.encodeUtf8 pass
+                  atomically $ do m ← readTVar (adbUserMap adb)
+                                  pure $ M.lookup name m ≡ Just hash
 
+getUserList ∷ MonadIO m ⇒ AuthDB → m [Text]
+getUserList = liftIO ∘ atomically ∘ (M.keys <$>) ∘ readTVar ∘ adbUserMap
 
-addUser :: MonadIO m => AuthDB -> String -> String -> m ()
+addUser ∷ MonadIO m ⇒ AuthDB → Text → Text → m ()
 addUser adb name pass
     = liftIO $
-      do sha1 <- return . fromJust =<< getDigestByName "SHA1"
-	 let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
-	 m <- atomically $ do m <- readTVar (adbUserMap adb)
-			      let m' = M.insert name hash m
-			      writeTVar (adbUserMap adb) m'
-			      return m'
+      do sha1 ← fromJust <$> getDigestByName "SHA1"
+	 let hash = digestBS' sha1 $ T.encodeUtf8 pass
+	 m ← atomically $ do m ← readTVar (adbUserMap adb)
+			     let m' = M.insert name hash m
+			     writeTVar (adbUserMap adb) m'
+			     return m'
 	 saveUserMap (adbFilePath adb) m
 
-
-delUser :: MonadIO m => AuthDB -> String -> m ()
+delUser ∷ MonadIO m ⇒ AuthDB → Text → m ()
 delUser adb name
     = liftIO $
-      do m <- atomically $ do m <- readTVar (adbUserMap adb)
-			      let m' = M.delete name m
-			      writeTVar (adbUserMap adb) m'
-			      return m'
+      do m ← atomically $ do m ← readTVar (adbUserMap adb)
+			     let m' = M.delete name m
+			     writeTVar (adbUserMap adb) m'
+			     return m'
 	 saveUserMap (adbFilePath adb) m
 
-
-loadUserMap :: FilePath -> IO UserMap
+loadUserMap ∷ FilePath → IO UserMap
 loadUserMap path
-    = do exist <- doesFileExist path
-         m     <- if exist then
-                      liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
-                            (readFile path)
-                  else
-                      return M.empty
-         sha1  <- return . fromJust =<< getDigestByName "SHA1"
-         return (initMap sha1 m)
+    = do exist ← doesFileExist path
+         m     ← if exist then
+                     fromJust ∘ deserializeMap id (decodeBase64BS ∘ T.encodeUtf8)
+                     <$> T.readFile path
+                 else
+                     pure M.empty
+         sha1  ← fromJust <$> getDigestByName "SHA1"
+         pure $ initMap sha1 m
     where
-      decodePair :: (String, String) -> (String, String)
-      decodePair (name, b64Hash)
-          = (UTF8.decodeString name, decodeBase64 b64Hash)
-
-      initMap :: Digest -> UserMap -> UserMap
+      initMap ∷ Digest → UserMap → UserMap
       initMap sha1 m
           | M.null m  = let name = "root"
-                            hash = digest sha1 ""
+                            hash = digestBS' sha1 ""
                         in
                           M.singleton name hash
           | otherwise = m
 
-
-saveUserMap :: FilePath -> UserMap -> IO ()
-saveUserMap path m
-    = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
-    where
-    encodePair :: (String, String) -> (String, String)
-    encodePair (name, hash)
-	= (UTF8.encodeString name, encodeBase64 hash)
+saveUserMap ∷ FilePath → UserMap → IO ()
+saveUserMap path
+    = T.writeFile path ∘ serializeMap id (T.decodeUtf8 ∘ encodeBase64BS)