modify auth-combinator example for gen auth

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

@@ -9,56 +9,53 @@
 {-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-import           Data.Aeson
+import           Control.Monad.Trans.Except (ExceptT, throwE)
-import           Data.ByteString          (ByteString)
+import           Data.Aeson                 hiding ((.:))
-import           Data.IORef
+import           Data.ByteString            (ByteString)
-import           Data.Text                (Text)
+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
-import           Servant.Server.Internal
 
--- Pretty much stolen/adapted from
+-- | This file contains an authenticated server using servant's generalized
--- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
+-- 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.
 
-type DBConnection = IORef [ByteString]
+-- | A user type that we "fetch from the database" after
-type DBLookup = DBConnection -> ByteString -> IO Bool
+-- performing authentication
+newtype User = User { unUser :: Text }
 
-initDB :: IO DBConnection
+-- | A (pure) database mapping keys to users.
-initDB = newIORef ["good password"]
+database :: Map ByteString User
+database = fromList [ ("key1", User "Anne Briggs")
+                    , ("key2", User "Bruce Cockburn")
+                    , ("key3", User "Ghédalia Tazartès")
+                    ]
 
-isGoodCookie :: DBLookup
+-- | A method that, when given a password, will return a User.
-isGoodCookie ref password = do
+-- This is our bespoke (and bad) authentication logic.
-  allowed <- readIORef ref
+lookupUser :: ByteString -> ExceptT ServantErr IO User
-  return (password `elem` allowed)
+lookupUser key = case Map.lookup key database of
+  Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
+  Just usr -> return usr
 
-data AuthProtected
+-- | 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`.
-instance (HasContextEntry context DBConnection, HasServer rest context)
+authHandler :: AuthHandler Request User
-  => HasServer (AuthProtected :> rest) context where
+authHandler =
-
+  let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
-  type ServerT (AuthProtected :> rest) m = ServerT rest m
+        Nothing -> throwE (err401 { errBody = "Missing auth header" })
-
+        Just authCookieKey -> lookupUser authCookieKey
-  route Proxy context subserver = WithRequest $ \ request ->
+  in mkAuthHandler handler
-    route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request
-      where
-        cookieCheck req = case lookup "Cookie" (requestHeaders req) of
-            Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
-            Just v  -> do
-              let dbConnection = getContextEntry context
-              authGranted <- isGoodCookie dbConnection v
-              if authGranted
-                then return $ Route ()
-                else return $ FailFatal err403 { errBody = "Invalid cookie" }
-
-type PrivateAPI = Get '[JSON] [PrivateData]
-
-type PublicAPI = Get '[JSON] [PublicData]
-
-type API = "private" :> AuthProtected :> PrivateAPI
-      :<|> PublicAPI
 
+-- | Data types that will be returned from various api endpoints
 newtype PrivateData = PrivateData { ssshhh :: Text }
   deriving (Eq, Show, Generic)
 
@@ -69,28 +66,58 @@ newtype PublicData = PublicData { somedata :: Text }
 
 instance ToJSON PublicData
 
+-- | Our private API that we want to be auth-protected.
+type PrivateAPI = Get '[JSON] [PrivateData]
+
+-- | Our public API that doesn't have any protection
+type PublicAPI = Get '[JSON] [PublicData]
+
+-- | Our API, with auth-protection
+type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
+      :<|> "public"  :> PublicAPI
+
+-- | A value holding our type-level API
 api :: Proxy API
 api = Proxy
 
+-- | We need to specify the data returned after authentication
+type instance AuthServerData (AuthProtect "cookie-auth") = User
+
+-- | The context that will be made available to request handlers. We supply the 
+-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
+-- of 'AuthProtect' can extract the handler and run it on the request.
+serverContext :: Context (AuthHandler Request User ': '[])
+serverContext = authHandler :. EmptyContext
+
+-- | 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 context
 server :: Server API
-server = return prvdata :<|> return pubdata
+server = privateDataFunc :<|> return publicData
 
-  where prvdata = [PrivateData "this is a secret"]
+  where privateDataFunc (User name) =
-        pubdata = [PublicData "this is a public piece of data"]
+          return [PrivateData ("this is a secret: " <> name)]
+        publicData = [PublicData "this is a public piece of data"]
 
+-- | run our server
 main :: IO ()
-main = do
+main = run 8080 (serveWithContext api serverContext server)
-  dbConnection <- initDB
-  let context = dbConnection :. EmptyContext
-  run 8080 (serveWithContext api context server)
 
-{- Sample session:
+{- Sample Session:
-$ curl http://localhost:8080/
+
+$ curl -XGET localhost:8080/private
+Missing auth header
+>>>>>>> modify auth-combinator example for gen auth
+>>>>>>> 8246c1f... modify auth-combinator example for gen auth
+
+$ 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 "servant-auth-cookie: bad-key"
+Invalid Cookie
+
+$ curl -XGET localhost:8080/public
 [{"somedata":"this is a public piece of data"}]
-$ curl http://localhost:8080/private
-Missing auth header.
-$ curl -H "Cookie: good password" http://localhost:8080/private
-[{"ssshhh":"this is a secret"}]
-$ curl -H "Cookie: bad password" http://localhost:8080/private
-Invalid cookie.
 -}
+

servant-examples/servant-examples.cabal

@@ -112,10 +112,12 @@ executable auth-combinator
       aeson >= 0.8
     , base >= 4.7 && < 5
     , bytestring
+    , containers
     , http-types
     , servant == 0.5.*
     , servant-server == 0.5.*
     , text
+    , transformers
     , wai
     , warp
   hs-source-dirs: auth-combinator