module Auth.PWHash
  ( apHash
  , hashLogin
  , PWHashMessage(..)
  ) where

import Import.NoFoundation
import Database.Persist.Sql (SqlBackendCanRead)

import Utils.Metrics
import Utils.Form

import qualified Data.CaseInsensitive as CI

import Yesod.Auth.Util.PasswordStore (verifyPasswordWith)

import qualified Yesod.Auth.Message as Msg


data HashLogin = HashLogin
  { hashIdent :: CI Text
  , hashPassword :: Text
  } deriving (Generic, Typeable)

data PWHashMessage = MsgPWHashIdent
                   | MsgPWHashIdentPlaceholder
                   | MsgPWHashPassword
                   | MsgPWHashPasswordPlaceholder
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)


hashForm :: ( RenderMessage (HandlerSite m) FormMessage
            , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
            , RenderMessage (HandlerSite m) PWHashMessage
            , MonadHandler m
            ) => WForm m (FormResult HashLogin)
hashForm = do
  MsgRenderer mr <- getMsgRenderer
  aFormToWForm $ HashLogin
    <$> areq ciField (fslpI MsgPWHashIdent (mr MsgPWHashIdentPlaceholder)) Nothing
    <*> areq passwordField (fslpI MsgPWHashPassword (mr MsgPWHashPasswordPlaceholder)) Nothing

apHash :: Text
apHash = "PWHash"

hashLogin :: forall site.
             ( YesodAuth site
             , YesodPersist site
             , SqlBackendCanRead (YesodPersistBackend site)
             , PersistRecordBackend User (YesodPersistBackend site)
             , RenderMessage site PWHashMessage
             , RenderMessage site AFormMessage
             , RenderMessage site (ValueRequired site)
             , Button site ButtonSubmit
             ) => PWHashAlgorithm -> AuthPlugin site
hashLogin pwHashAlgo = AuthPlugin{..}
  where
    apName :: Text
    apName = apHash

    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
    apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
      ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard hashForm
      tp <- getRouteToParent

      resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
        user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
        case user of
          Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic.
                observeLoginOutcome apName LoginSuccessful
                setCredsRedirect $ Creds apName userIdent []
          other -> do
            $logDebugS apName $ tshow other
            observeLoginOutcome apName LoginInvalidCredentials
            loginErrorMessageI LoginR Msg.InvalidLogin

      maybe (redirect $ tp LoginR) return resp
    apDispatch _ [] = badMethod
    apDispatch _ _ = notFound

    apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
    apLogin toMaster = do
      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard hashForm
      let loginForm = wrapForm login FormSettings
            { formMethod = POST
            , formAction = Just . SomeRoute . toMaster $ PluginR apName []
            , formEncoding = loginEnctype
            , formAttrs = [("uw-no-navigate-away-prompt","")]
            , formSubmit = FormSubmit
            , formAnchor = Just "login--hash" :: Maybe Text
            }
      $(widgetFile "widgets/hash-login-form/hash-login-form")