add an auth combinator example
This commit is contained in:
parent
e371fb886f
commit
4c86c7395c
2 changed files with 95 additions and 4 deletions
78
servant-examples/auth-combinator/auth-combinator.hs
Normal file
78
servant-examples/auth-combinator/auth-combinator.hs
Normal file
|
@ -0,0 +1,78 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
import Data.Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import Servant
|
||||
import Servant.Server.Internal
|
||||
|
||||
-- Pretty much stolen/adapted from
|
||||
-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
|
||||
|
||||
type DBLookup = ByteString -> IO Bool
|
||||
|
||||
isGoodCookie :: DBLookup
|
||||
isGoodCookie = return . (== "good password")
|
||||
|
||||
data AuthProtected
|
||||
|
||||
instance HasServer rest => HasServer (AuthProtected :> rest) where
|
||||
type ServerT' (AuthProtected :> rest) m = ServerT' rest m
|
||||
|
||||
route Proxy a request respond =
|
||||
case lookup "Cookie" (requestHeaders request) of
|
||||
Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header."
|
||||
Just v -> do
|
||||
authGranted <- isGoodCookie v
|
||||
if authGranted
|
||||
then route (Proxy :: Proxy rest) a request respond
|
||||
else respond . succeedWith $ responseLBS status403 [] "Invalid cookie."
|
||||
|
||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
||||
|
||||
type PublicAPI = Get '[JSON] [PublicData]
|
||||
|
||||
type API = "private" :> AuthProtected :> PrivateAPI
|
||||
:<|> PublicAPI
|
||||
|
||||
newtype PrivateData = PrivateData { ssshhh :: Text }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON PrivateData
|
||||
|
||||
newtype PublicData = PublicData { somedata :: Text }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON PublicData
|
||||
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
server :: Server API
|
||||
server = return prvdata :<|> return pubdata
|
||||
|
||||
where prvdata = [PrivateData "this is a secret"]
|
||||
pubdata = [PublicData "this is a public piece of data"]
|
||||
|
||||
main :: IO ()
|
||||
main = run 8080 (serve api server)
|
||||
|
||||
{- Sample session:
|
||||
$ curl http://localhost:8080/
|
||||
[{"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.
|
||||
-}
|
|
@ -1,7 +1,8 @@
|
|||
name: servant-examples
|
||||
version: 0.3
|
||||
synopsis: Example programs for servant
|
||||
description: Example programs for servant
|
||||
description: Example programs for servant,
|
||||
showcasing solutions to common needs.
|
||||
homepage: http://haskell-servant.github.io/
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
|
@ -10,13 +11,10 @@ maintainer: alpmestan@gmail.com
|
|||
-- copyright:
|
||||
category: Web
|
||||
build-type: Simple
|
||||
-- extra-source-files:
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable hackage
|
||||
main-is: hackage.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
aeson >= 0.8
|
||||
, base >=4.7
|
||||
|
@ -41,3 +39,18 @@ executable wai-middleware
|
|||
, warp
|
||||
hs-source-dirs: wai-middleware
|
||||
default-language: Haskell2010
|
||||
|
||||
executable auth-combinator
|
||||
main-is: auth-combinator.hs
|
||||
build-depends:
|
||||
aeson >= 0.8
|
||||
, base >= 4.7
|
||||
, bytestring
|
||||
, http-types
|
||||
, servant
|
||||
, servant-server
|
||||
, text
|
||||
, wai
|
||||
, warp
|
||||
hs-source-dirs: auth-combinator
|
||||
default-language: Haskell2010
|
||||
|
|
Loading…
Reference in a new issue