never executed always true always false

    1 module PureClaw.Gateway.Auth
    2   ( -- * Authentication
    3     authenticateRequest
    4   , AuthError (..)
    5     -- * Pairing
    6   , handlePairRequest
    7   , PairRequest (..)
    8   , PairResponse (..)
    9   ) where
   10 
   11 import Data.Aeson
   12 import Data.ByteString (ByteString)
   13 import Data.Text (Text)
   14 import Data.Text.Encoding qualified as TE
   15 import Data.ByteString.Base16 qualified as Base16
   16 import Data.ByteString qualified as BS
   17 
   18 import PureClaw.Core.Errors
   19 import PureClaw.Handles.Log
   20 import PureClaw.Security.Pairing
   21 import PureClaw.Security.Secrets
   22 
   23 -- | Authentication errors.
   24 data AuthError
   25   = MissingToken
   26   | InvalidToken
   27   | MalformedHeader
   28   deriving stock (Show, Eq)
   29 
   30 instance ToPublicError AuthError where
   31   toPublicError _ = NotAllowedError
   32 
   33 -- | Extract and validate a bearer token from an Authorization header value.
   34 -- Expects the format: "Bearer <token>"
   35 authenticateRequest :: PairingState -> ByteString -> LogHandle -> IO (Either AuthError ())
   36 authenticateRequest ps authHeader lh =
   37   case extractToken authHeader of
   38     Nothing -> do
   39       _lh_logWarn lh "Auth: malformed Authorization header"
   40       pure (Left MalformedHeader)
   41     Just tokenBytes -> do
   42       let rawBytes = Base16.decodeLenient tokenBytes
   43           token = mkBearerToken rawBytes
   44       valid <- verifyToken ps token
   45       if valid
   46         then pure (Right ())
   47         else do
   48           _lh_logWarn lh "Auth: invalid bearer token"
   49           pure (Left InvalidToken)
   50 
   51 -- | Extract the raw token bytes from a "Bearer <token>" header value.
   52 extractToken :: ByteString -> Maybe ByteString
   53 extractToken header =
   54   let prefix = "Bearer "
   55   in if BS.isPrefixOf prefix header
   56      then Just (BS.drop (BS.length prefix) header)
   57      else Nothing
   58 
   59 -- | Request body for the /pair endpoint.
   60 newtype PairRequest = PairRequest
   61   { _pr_code :: Text
   62   }
   63   deriving stock (Show, Eq)
   64 
   65 instance FromJSON PairRequest where
   66   parseJSON = withObject "PairRequest" $ \o ->
   67     PairRequest <$> o .: "code"
   68 
   69 -- | Response body for a successful pairing.
   70 newtype PairResponse = PairResponse
   71   { _prsp_token :: Text
   72   }
   73   deriving stock (Show, Eq)
   74 
   75 instance ToJSON PairResponse where
   76   toJSON pr = object ["token" .= _prsp_token pr]
   77 
   78 -- | Handle a pairing request: validate the code and return a bearer token.
   79 handlePairRequest :: PairingState -> Text -> PairRequest -> LogHandle -> IO (Either PairingError PairResponse)
   80 handlePairRequest ps clientId req lh = do
   81   let code = mkPairingCode (_pr_code req)
   82   _lh_logInfo lh $ "Pair: attempt from client " <> clientId
   83   result <- attemptPair ps clientId code
   84   case result of
   85     Left err -> do
   86       _lh_logWarn lh $ "Pair: failed for client " <> clientId
   87       pure (Left err)
   88     Right token ->
   89       withBearerToken token $ \tokenBytes -> do
   90         _lh_logInfo lh $ "Pair: success for client " <> clientId
   91         pure (Right (PairResponse (TE.decodeUtf8 (Base16.encode tokenBytes))))