@@ -1,124 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−
12−import Control.Monad.Trans.Except (ExceptT, throwE)
13−import Data.Aeson hiding ((.:))
14−import Data.ByteString (ByteString)
15−import Data.Monoid ((<>))
16−import Data.Map (Map, fromList)
17−import qualified Data.Map as Map
18−import Data.Text (Text)
19−import GHC.Generics
20−import Network.Wai
21−import Network.Wai.Handler.Warp
22−import Servant
23−import Servant.Server.Experimental.Auth
24−
25−-- | This file contains an authenticated server using servant's generalized
26−-- authentication support. Our basic authentication scheme is trivial: we
27−-- look for a cookie named "servant-auth-cookie" and its value will contain
28−-- a key, which we use to lookup a User. Obviously this is an absurd example,
29−-- but we pick something simple and non-standard to show you how to extend
30−-- servant's support for authentication.
31−
32−-- | A user type that we "fetch from the database" after
33−-- performing authentication
34−newtype User = User { unUser :: Text }
35−
36−-- | A (pure) database mapping keys to users.
37−database :: Map ByteString User
38−database = fromList [ ("key1", User "Anne Briggs")
39− , ("key2", User "Bruce Cockburn")
40− , ("key3", User "Ghédalia Tazartès")
41− ]
42−
43−-- | A method that, when given a password, will return a User.
44−-- This is our bespoke (and bad) authentication logic.
45−lookupUser :: ByteString -> ExceptT ServantErr IO User
46−lookupUser key = case Map.lookup key database of
47− Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
48− Just usr -> return usr
49−
50−-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
51−-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
52−authHandler :: AuthHandler Request User
53−authHandler =
54− let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
55− Nothing -> throwE (err401 { errBody = "Missing auth header" })
56− Just authCookieKey -> lookupUser authCookieKey
57− in mkAuthHandler handler
58−
59−-- | Data types that will be returned from various api endpoints
60−newtype PrivateData = PrivateData { ssshhh :: Text }
61− deriving (Eq, Show, Generic)
62−
63−instance ToJSON PrivateData
64−
65−newtype PublicData = PublicData { somedata :: Text }
66− deriving (Eq, Show, Generic)
67−
68−instance ToJSON PublicData
69−
70−-- | Our private API that we want to be auth-protected.
71−type PrivateAPI = Get '[JSON] [PrivateData]
72−
73−-- | Our public API that doesn't have any protection
74−type PublicAPI = Get '[JSON] [PublicData]
75−
76−-- | Our API, with auth-protection
77−type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
78− :<|> "public" :> PublicAPI
79−
80−-- | A value holding our type-level API
81−api :: Proxy API
82−api = Proxy
83−
84−-- | We need to specify the data returned after authentication
85−type instance AuthServerData (AuthProtect "cookie-auth") = User
86−
87−-- | The context that will be made available to request handlers. We supply the
88−-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
89−-- of 'AuthProtect' can extract the handler and run it on the request.
90−serverContext :: Context (AuthHandler Request User ': '[])
91−serverContext = authHandler :. EmptyContext
92−
93−-- | Our API, where we provide all the author-supplied handlers for each end
94−-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
95−-- argument. We dont' worry about the authentication instrumentation here,
96−-- that is taken care of by supplying context
97−server :: Server API
98−server = privateDataFunc :<|> return publicData
99−
100− where privateDataFunc (User name) =
101− return [PrivateData ("this is a secret: " <> name)]
102− publicData = [PublicData "this is a public piece of data"]
103−
104−-- | run our server
105−main :: IO ()
106−main = run 8080 (serveWithContext api serverContext server)
107−
108−{- Sample Session:
109−
110−$ curl -XGET localhost:8080/private
111−Missing auth header
112−>>>>>>> modify auth-combinator example for gen auth
113−>>>>>>> 8246c1f... modify auth-combinator example for gen auth
114−
115−$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
116−[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
117−
118−$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
119−Invalid Cookie
120−
121−$ curl -XGET localhost:8080/public
122−[{"somedata":"this is a public piece of data"}]
123−-}
124−