From 523282e6941b4e2e20ba834ed17e545bcdf97416 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 4 Jul 2018 12:01:57 +0200
Subject: [PATCH] Use canned password management instead of implementing our
 own

---
 src/Application.hs | 14 +++++---------
 src/Foundation.hs  | 22 +++++++++++++---------
 src/Model.hs       |  2 +-
 3 files changed, 19 insertions(+), 19 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 37ba273b9..3d23278e7 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -38,11 +38,8 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 
-import qualified Crypto.KDF.Argon2 as Argon2
-import Crypto.Error (CryptoFailable(..))
-import qualified Data.ByteString.Base64.URL as Base64 (encode)
 import qualified Data.Text.Encoding as Text
-import Crypto.Random (MonadRandom(..))
+import Yesod.Auth.Util.PasswordStore
 
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Yaml as Yaml
@@ -212,9 +209,8 @@ addPWEntry :: FilePath {-^ Password file -}
            -> User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry pwFile pwUser (Text.encodeUtf8 -> pw) = do
-  pwSalt'@(Text.decodeUtf8 . Base64.encode -> pwSalt) <- getRandomBytes 32
-  let pwEntry = PWEntry{..}
-      CryptoPassed (Text.decodeUtf8 . Base64.encode -> pwHash) = Argon2.hash Argon2.defaultOptions pw pwSalt' 256
+addPWEntry pwFile pwUser' (Text.encodeUtf8 -> pw) = do
+  (Text.decodeUtf8 -> pwHash) <- makePassword pw 14
+  let pwEntry = PWEntry{ pwUser = pwUser', .. }
   c <- either (const []) id <$> Yaml.decodeFileEither pwFile
-  Yaml.encodeFile pwFile $ c ++ [pwEntry]
+  Yaml.encodeFile pwFile $ pwEntry : [ c' | c' <- c, ((/=) `on` (userIdent . pwUser)) c' pwEntry ]
diff --git a/src/Foundation.hs b/src/Foundation.hs
index b9a042343..059237c6f 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -38,12 +38,12 @@ import qualified Data.Text.Encoding as TE
 import Data.ByteArray (convert)
 import Crypto.Hash (Digest, SHAKE256)
 import Crypto.Hash.Conduit (sinkHash)
-import qualified Crypto.KDF.Argon2 as Argon2
-import Crypto.Error (CryptoFailable(..))
+
+import Yesod.Auth.Util.PasswordStore
 
 import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only
 
-import qualified Data.ByteString.Base64.URL as Base64 (encode, decodeLenient)
+import qualified Data.ByteString.Base64.URL as Base64 (encode)
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as Lazy.ByteString
@@ -1020,24 +1020,28 @@ authPWFile fp = AuthPlugin{..}
     apDispatch "GET" [] = do
       authData <- lookupBasicAuth
       pwdata <- liftIO $ Yaml.decodeFileEither fp
+
+      addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
+
+      case pwdata of
+        Left err -> $logDebugS "Auth" $ tshow err
+        Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
+
       case (authData, pwdata) of
-        (_, Left _) -> permissionDenied "Invalid password file"
         (Nothing, _) -> do
-          addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
           notAuthenticated
         (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
-          | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Base64.decodeLenient . Text.encodeUtf8 -> pwHash), pwSalt = (Base64.decodeLenient . Text.encodeUtf8 -> pwSalt) } ]
+          | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
               <- [ pwe | pwe@PWEntry{..} <- pwdata'
                        , let User{..} = pwUser
                        , userIdent  == usr
                        , userPlugin == apName
                  ]
-          , CryptoPassed hash <- Argon2.hash Argon2.defaultOptions pw pwSalt 256
-          , hash == pwHash
+          , verifyPassword pw pwHash
             -> lift $ do
               runDB . void $ insertUnique pwUser
               setCredsRedirect $ Creds apName userIdent []
-          | otherwise -> permissionDenied "Invalid auth"
+        _ -> permissionDenied "Invalid auth"
     apDispatch _ _ = notFound
 
 
diff --git a/src/Model.hs b/src/Model.hs
index 538a675cc..aef13b517 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -28,6 +28,6 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
 
 data PWEntry = PWEntry
   { pwUser :: User
-  , pwSalt, pwHash :: Text
+  , pwHash :: Text
   } deriving (Show)
 $(deriveJSON defaultOptions ''PWEntry)