{-# LANGUAGE OverloadedStrings #-}

module Inf.Web.Cookies
  ( Cookies
  , getUser
  , verifyUser
  , authCookie
  , dumpCookies
  , parseCookies
  ) where

import qualified Crypto.PasswordStore as Password
import qualified Data.ByteString as BS
import qualified Data.Text as TS
import qualified Data.Text.Encoding as EncodingS

import qualified Inf.DB as DB
import qualified Inf.DB.Monad as DB
import qualified Inf.Log as Log

type Cookies = [(BS.ByteString, BS.ByteString)]

dumpCookies :: Cookies -> BS.ByteString
dumpCookies cks = do
  BS.intercalate "; " [ BS.concat [k, "=", v]
                      | (k, v) <- cks
                      ]

-- | Split a cookie string represented in the usual way into a list of
-- key/value pairs
parseCookies :: BS.ByteString -> Maybe Cookies
parseCookies inp = do
  let (chunk, rest) = BS.breakSubstring "; " inp
  x <- case BS.breakSubstring "=" chunk of
      (_, "") -> Nothing
      (k, v)  -> pure (k, BS.tail v)
  xs <- case rest of
    "" -> pure []
    rs -> parseCookies (BS.drop 2 rs)
  pure (x:xs)

authCookie :: BS.ByteString -> BS.ByteString -> Cookies
authCookie user pass =
  [("USERDATA", BS.concat [user, ":", pass])]

verifyUser
  :: DB.Connection
  -> BS.ByteString
  -> BS.ByteString
  -> IO (Maybe TS.Text)
verifyUser conn user passwd = do
  let userTxt = EncodingS.decodeUtf8 user
  authMb <- DB.runDB conn (DB.userAuthData userTxt)
  case authMb of
    Nothing -> do
      Log.warn [ "unable to find login data for", TS.unpack userTxt ]
      pure Nothing
    Just auth
      | Password.verifyPassword passwd auth ->
        pure (Just userTxt)
      | otherwise -> do
          Log.error [ "bad password for", TS.unpack userTxt ]
          pure Nothing

-- | Find and verify a USERDATA cookie
getUser :: DB.Connection -> Maybe BS.ByteString -> IO (Maybe TS.Text)
getUser conn c = do
  let userDataMb = c >>= parseCookies >>= lookup "USERDATA"
  case userDataMb of
    Nothing -> pure Nothing
    Just userData -> do
      let (name, pass) = BS.breakSubstring ":" userData
      verifyUser conn name (BS.tail pass)