From 61c5e0590667ac77c98efc3ca75bc5a86604107c Mon Sep 17 00:00:00 2001
From: aaron levin <aaron.levin@soundcloud.com>
Date: Wed, 27 Jan 2016 19:55:17 +0100
Subject: [PATCH] Make auth-combinator example much clearer

---
 .../auth-combinator/auth-combinator.hs        | 47 ++++++++++++-------
 servant-examples/servant-examples.cabal       |  1 +
 2 files changed, 32 insertions(+), 16 deletions(-)

diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs
index 9773be83..22674bfe 100644
--- a/servant-examples/auth-combinator/auth-combinator.hs
+++ b/servant-examples/auth-combinator/auth-combinator.hs
@@ -13,32 +13,46 @@ import           Control.Monad.Trans.Except (ExceptT, throwE)
 import           Data.Aeson                 hiding ((.:))
 import           Data.ByteString            (ByteString)
 import           Data.Monoid                ((<>))
+import           Data.Map                   (Map, fromList)
+import qualified Data.Map                   as Map
 import           Data.Text                  (Text)
 import           GHC.Generics
 import           Network.Wai
 import           Network.Wai.Handler.Warp
 import           Servant
 
+-- | This file contains an authenticated server using servant's generalized
+-- authentication support. Our basic authentication scheme is trivial: we
+-- look for a cookie named "servant-auth-cookie" and its value will contain
+-- a key, which we use to lookup a User. Obviously this is an absurd example,
+-- but we pick something simple and non-standard to show you how to extend
+-- servant's support for authentication.
+
 -- | A user type that we "fetch from the database" after
 -- performing authentication
 newtype User = User { unUser :: Text }
 
+-- | A (pure) database mapping keys to users.
+database :: Map ByteString User
+database = fromList [ ("key1", User "Anne Briggs")
+                    , ("key2", User "Bruce Cockburn")
+                    , ("key3", User "Ghédalia Tazartès")
+                    ]
 
 -- | A method that, when given a password, will return a User.
 -- This is our bespoke (and bad) authentication logic.
 lookupUser :: ByteString -> ExceptT ServantErr IO User
-lookupUser cookie =
-  if cookie == "good password"
-  then return (User "user")
-  else throwE (err403 { errBody = "Invalid Cookie" })
+lookupUser key = case Map.lookup key database of
+  Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
+  Just usr -> return usr
 
 -- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
 -- we look for a Cookie and pass the value of the cookie to `lookupUser`.
 authHandler :: AuthHandler Request User
 authHandler =
-  let handler req = case lookup "Cookie" (requestHeaders req) of
+  let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
         Nothing -> throwE (err401 { errBody = "Missing auth header" })
-        Just cookie -> lookupUser cookie
+        Just authCookieKey -> lookupUser authCookieKey
   in mkAuthHandler handler
 
 -- | Data types that will be returned from various api endpoints
@@ -75,15 +89,16 @@ type instance AuthReturnType (AuthProtect "cookie-auth") = User
 serverConfig :: Config (AuthHandler Request User ': '[])
 serverConfig = authHandler :. EmptyConfig
 
--- | Our API, where we provide all the author-supplied handlers for each end point.
--- note that 'prvdata' is a function that takes 'User' as an argument. We dont' worry
--- about the authentication instrumentation here, that is taken care of by supplying
--- configuration
+-- | Our API, where we provide all the author-supplied handlers for each end
+-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
+-- argument. We dont' worry about the authentication instrumentation here,
+-- that is taken care of by supplying configuration
 server :: Server API
-server = prvdata :<|> return pubdata
+server = privateDataFunc :<|> return publicData
 
-  where prvdata (User name) = return [PrivateData ("this is a secret: " <> name)]
-        pubdata = [PublicData "this is a public piece of data"]
+  where privateDataFunc (User name) =
+          return [PrivateData ("this is a secret: " <> name)]
+        publicData = [PublicData "this is a public piece of data"]
 
 -- | run our server
 main :: IO ()
@@ -94,10 +109,10 @@ main = run 8080 (serve api serverConfig server)
 $ curl -XGET localhost:8080/private
 Missing auth header
 
-$ curl -XGET localhost:8080/private -H "Cookie: good password"
-[{"ssshhh":"this is a secret: user"}]
+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
+[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
 
-$ curl -XGET localhost:8080/private -H "Cookie: bad password"
+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
 Invalid Cookie
 
 $ curl -XGET localhost:8080/public
diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal
index d00ce302..a73b9871 100644
--- a/servant-examples/servant-examples.cabal
+++ b/servant-examples/servant-examples.cabal
@@ -96,6 +96,7 @@ executable auth-combinator
       aeson >= 0.8
     , base >= 4.7 && < 5
     , bytestring
+    , containers
     , http-types
     , servant == 0.5.*
     , servant-server == 0.5.*