{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module HaveIBeenPwned where
import "cryptonite" Crypto.Hash
import Control.Exception
import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding
import Network.HTTP.Client
import Network.HTTP.Types.Status (Status(..))
import Safe (readMay)
data HaveIBeenPwnedConfig = HaveIBeenPwnedConfig
{ _haveIBeenPwnedConfig_manager :: Manager
, _haveIBeenPwnedConfig_apihost :: Text
}
data HaveIBeenPwnedResult =
HaveIBeenPwnedResult_Secure
| HaveIBeenPwnedResult_Pwned Int
| HaveIBeenPwnedResult_Error
deriving (Eq, Ord, Show)
class Monad m => MonadPwned m where
haveIBeenPwned :: Text -> m HaveIBeenPwnedResult
newtype PwnedT m a = PwnedT { unPwnedT :: ReaderT HaveIBeenPwnedConfig m a }
deriving (Functor, Applicative, Monad , MonadIO, MonadLogger
, MonadTrans
)
runPwnedT :: PwnedT m a -> HaveIBeenPwnedConfig -> m a
runPwnedT (PwnedT (ReaderT f)) = f
mapPwnedT :: (m a -> n b) -> PwnedT m a -> PwnedT n b
mapPwnedT f = PwnedT . mapReaderT f . unPwnedT
instance MonadReader r m => MonadReader r (PwnedT m) where
ask = lift ask
local = mapPwnedT . local
reader = lift . reader
instance (MonadLogger m, MonadIO m) => MonadPwned (PwnedT m) where
haveIBeenPwned password = do
let (pfx, rest) = passwdDigest password
cfg <- PwnedT ask
let request = parseRequest_ $ T.unpack $ T.concat [_haveIBeenPwnedConfig_apihost cfg, "/", pfx]
result' <- liftIO $ try $ httpLbs request (_haveIBeenPwnedConfig_manager cfg)
case result' of
Left err -> do
$(logError) $ T.pack $ show @ HttpException $ err
return HaveIBeenPwnedResult_Error
Right result -> case responseStatus result of
Status 200 _ -> do
let r = parseHIBPResponse (responseBody result) rest
case r of
HaveIBeenPwnedResult_Error ->
$(logError) $ "Parsing number of occurrences failed. (Not an Int)."
_ -> pure ()
pure r
Status code phrase -> do
$(logError) $ T.pack $ show $ Status code phrase
return HaveIBeenPwnedResult_Error
passwdDigest :: Text -> (Text, Text)
passwdDigest passwd = (T.take 5 digest, T.drop 5 digest)
where digest = T.toUpper $ T.pack $ show $ sha1 $ encodeUtf8 passwd
sha1 :: ByteString -> Digest SHA1
sha1 = hash
parseHIBPResponse :: LBS.ByteString -> Text -> HaveIBeenPwnedResult
parseHIBPResponse response suffix =
let
digests :: [(LT.Text, Maybe Int)]
digests = fmap (fmap (readMay . LT.unpack . LT.drop 1) . LT.breakOn ":") $ LT.lines $ Data.Text.Lazy.Encoding.decodeUtf8 response
in case filter ((LT.fromStrict suffix ==) . fst) digests of
((_,n):_) -> maybe HaveIBeenPwnedResult_Error HaveIBeenPwnedResult_Pwned n
[] -> HaveIBeenPwnedResult_Secure