fix(web): send correct status codes on auth failures

Failure to authenticate due to a malformed or missing auth token is now
reported differently than failure to authenticate due to a blatantly
incorrect auth token.

Fixes #53, #54.

Author: atalii

web/app/Auth.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Auth (register, unregister, checkAuth, TokenStore, initTokenStore, verifyAdmin) where
+module Auth (register, unregister, checkAuth, TokenStore, initTokenStore, verifyAdmin, AuthStatus(..)) where
 
 import Control.Concurrent.STM (STM, modifyTVar, newTVarIO)
 import Control.Concurrent.STM.TVar (TVar, readTVar)
@@ -17,6 +17,8 @@ import Data.Text.Lazy qualified as L
 import Data.UUID (UUID, fromText)
 import Data.UUID.V4 (nextRandom)
 
+data AuthStatus = BadToken | Allowed | Disallowed
+
 data BadPassfileException = WrongSpec | CantDecode deriving (Show)
 
 data RequestException = BadTokenException deriving (Show)
@@ -50,16 +52,15 @@ initTokenStore =
     parse [cred] = return $ pack cred
     parse _ = throwIO WrongSpec
 
-checkAuth :: TokenStore -> Name -> L.Text -> IO Bool
+checkAuth :: TokenStore -> Name -> L.Text -> IO AuthStatus
 checkAuth ts name t = case fromText $ L.toStrict t of
   Just token -> atomically $ checkAuth' token
-  Nothing -> throwIO BadTokenException
+  Nothing -> return BadToken
   where
-    checkAuth' :: UUID -> STM Bool
     checkAuth' uuid = check uuid . tokens <$> readTVar ts
     check uuid toks = case toks Map.!? name of
-      Just x -> x == uuid
-      Nothing -> False
+      Just x -> if x == uuid then Allowed else Disallowed
+      Nothing -> Disallowed
 
 unregister :: TokenStore -> Name -> IO ()
 unregister ts name = atomically $ modifyTVar ts unregister'

web/app/Main.hs

@@ -4,13 +4,13 @@
 
 module Main where
 
-import Auth (TokenStore, checkAuth, initTokenStore, register, unregister, verifyAdmin)
+import Auth (TokenStore, checkAuth, initTokenStore, register, unregister, verifyAdmin, AuthStatus(..))
 import Control.Monad.IO.Class (liftIO)
 import qualified Data.Text as T
 import Data.Text.Lazy (pack, toStrict)
 import Data.UUID (toText)
 import GHC.Conc (atomically)
-import Network.HTTP.Types.Status (badRequest400, unauthorized401, conflict409, internalServerError500)
+import Network.HTTP.Types.Status (badRequest400, unauthorized401, forbidden403, conflict409, internalServerError500)
 import Proc (Proc, call, kill, launch, mkCommand, mkUnvalidatedCommand, mkComp)
 import System.Environment (getArgs)
 import System.Posix.Signals (Handler (..), installHandler, sigINT)
@@ -75,8 +75,9 @@ runWebServer proc ts =
         check (Just uuid) = liftIO $ checkAuth ts name uuid
         check Nothing = status unauthorized401 >> finish
 
-        serve True = return name
-        serve False = status unauthorized401 >> finish
+        serve Allowed = return name
+        serve Disallowed = status forbidden403 >> finish
+	serve BadToken = status unauthorized401 >> finish
 
     callCreate name color = callCmd $ mkCommand (mkComp name) (mkComp "CREATE") [mkComp color]