update auth-comb. tutorial for new GADT-based auth

servant-examples/auth-combinator/auth-combinator.hs

@@ -7,60 +7,69 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 import Data.Aeson
 import Data.ByteString (ByteString)
-import Data.ByteString.Builder.Internal (byteStringCopy)
+import qualified Data.ByteString as B
 import Data.Monoid ((<>))
 import Data.Text (Text)
 import GHC.Generics
-import Network.HTTP.Types
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Servant
 import Servant.API.Authentication
-import Servant.Server.Internal
-import Servant.Server.Internal.Authentication (strictProtect, AuthHandlers(AuthHandlers))
 
 -- | Data we will use to test for authentication
 data CookieAuth = CookieAuth { cookie :: ByteString }
 
+-- | An ADT to index errors we may encounter when retrieving a cookie from a request
+data CookieFromRequestError = CookieNotPresent
+                            | CookieInvalid
+
 -- | A 'User' datatype we get once the authentication data is tested.
 type User = ByteString
 
+-- | An ADT to index errors we may encounter when retrieving a user from the database
+-- based on the cookie
+data UserFromCookieError = NoUserAssociatedWithCookie
+                         | MoreThanOneCookieInDatabase Int
+
 -- | We will look up authentication data in the database and extract a User.
-type DBLookup = CookieAuth -> IO (Maybe User)
+type DBLookup = CookieAuth -> IO (Either UserFromCookieError User)
 
 -- | Method that tests for authentication and extracts a User type.
-isGoodCookie :: DBLookup
+userFromCookie :: DBLookup
-isGoodCookie (CookieAuth cookie) = if cookie == "good cookie" then return (Just "one user") else return Nothing
+userFromCookie (CookieAuth cookie) = if cookie == "good cookie" then return (Right "one user") else return (Left NoUserAssociatedWithCookie)
 
--- | Response handlers: what do we do when authentication doesn't work.
+-- | a handler that takes a cookie error and returns a ServantErr in IO
-cookieAuthHandlers :: AuthHandlers CookieAuth
+missingCookieHandler :: OnMissing IO ServantErr 'Strict CookieFromRequestError
-cookieAuthHandlers = AuthHandlers missingAuth notAuthenticated
+missingCookieHandler =
-  where
+    let handler error = case error of
-    missingAuth :: IO Response
+            CookieNotPresent -> return $ err401 { errReasonPhrase = "No cookie" } 
-    missingAuth = return $ (responseBuilder status401 [] "Missing Cookie header.")
+            CookieInvalid    -> return (err401 { errReasonPhrase = "Invalid Cookie" })
+    in StrictMissing handler
 
-  route Proxy subserver = WithRequest $ \ request ->
+-- | a handler that takes a Cookie + extraction error and returns a IO ServantErr.
-    route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
+-- This handler is called when a valid authentication data (e.g. Cookie) was extracted
-      where
+-- from the request, but we were not able to find a valid user in our database.
-        cookieCheck req = case lookup "Cookie" (requestHeaders req) of
+unauthenticatedHandler :: OnUnauthenticated IO ServantErr 'Strict UserFromCookieError CookieAuth
-            Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
+unauthenticatedHandler =
-            Just v  -> do
+    let handler error _ = case error of
-              authGranted <- isGoodCookie v
+            NoUserAssociatedWithCookie ->
-              if authGranted
+                return (err403 { errReasonPhrase = "you don't exist" })
-                then return $ Route ()
+            (MoreThanOneCookieInDatabase i) ->
-                else return $ FailFatal err403 { errBody = "Invalid cookie" }
+                return (err403 { errReasonPhrase = "we found " <> show i <> " of you. WAT?" })
-
+    in StrictUnauthenticated handler
-    notAuthenticated :: CookieAuth -> IO Response
-    notAuthenticated (CookieAuth cookie) = return $
-        responseBuilder status401 [] ("Invalid cookie: " <> byteStringCopy cookie)
 
 -- | 'AuthData' is a typeclass that provides a method to extract authentication
--- data from a 'Request'
+-- data from a 'Request'.
-instance AuthData CookieAuth where
+instance AuthData CookieAuth CookieFromRequestError where
-    authData req = fmap CookieAuth (lookup "Cookie" (requestHeaders req))
+    authData req = case lookup "Cookie" (requestHeaders req) of
+        Nothing -> Left CookieNotPresent
+        (Just cookieVal) -> if B.length cookieVal > 10
+                            then Left CookieInvalid
+                            else Right (CookieAuth cookieVal)
 
 -- | Some data we will return from our API that is protected
 newtype PrivateData = PrivateData { ssshhh :: Text }
@@ -80,15 +89,21 @@ type PrivateAPI = Get '[JSON] [PrivateData]
 -- | Public API (non-authenticated) as a type
 type PublicAPI = Get '[JSON] [PublicData]
 
+-- | A type alias for our auth protection
+type CookieAuthProtected = AuthProtect CookieAuth User 'Strict CookieFromRequestError 'Strict UserFromCookieError
+
 -- | Our full API as a type with authentication
-type API = AuthProtect CookieAuth User 'Strict :> "private" :>  PrivateAPI
+type API = CookieAuthProtected :> "private" :>  PrivateAPI
       :<|> PublicAPI
 
 api :: Proxy API
 api = Proxy
 
 server :: Server API
-server = strictProtect isGoodCookie cookieAuthHandlers (const (return prvdata))
+server = authProtect missingCookieHandler
+                     unauthenticatedHandler
+                     userFromCookie
+                     (\_ -> return prvdata)
     :<|> return pubdata
 
   where prvdata = [PrivateData "this is a secret"]