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

97 lines
3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
2015-04-24 14:00:57 +02:00
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Aeson
import Data.ByteString (ByteString)
2016-01-14 23:43:48 +01:00
import Data.IORef
import Data.Text (Text)
import GHC.Generics
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Servant.Server.Internal
2015-04-24 14:00:57 +02:00
-- Pretty much stolen/adapted from
-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
2016-01-14 23:43:48 +01:00
type DBConnection = IORef [ByteString]
type DBLookup = DBConnection -> ByteString -> IO Bool
initDB :: IO DBConnection
initDB = newIORef ["good password"]
2015-04-24 14:00:57 +02:00
isGoodCookie :: DBLookup
2016-01-14 23:43:48 +01:00
isGoodCookie ref password = do
allowed <- readIORef ref
return (password `elem` allowed)
2015-04-24 14:00:57 +02:00
data AuthProtected
2016-02-28 23:23:32 +01:00
instance (HasContextEntry context DBConnection, HasServer rest context)
=> HasServer (AuthProtected :> rest) context where
2015-05-03 01:53:38 +02:00
type ServerT (AuthProtected :> rest) m = ServerT rest m
2015-04-24 14:00:57 +02:00
2016-02-28 23:23:32 +01:00
route Proxy context subserver = WithRequest $ \ request ->
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
2016-02-28 23:23:32 +01:00
let dbConnection = getContextEntry context
2016-01-14 23:43:48 +01:00
authGranted <- isGoodCookie dbConnection v
if authGranted
then return $ Route ()
else return $ FailFatal err403 { errBody = "Invalid cookie" }
2015-04-24 14:00:57 +02:00
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 ()
2016-01-14 23:43:48 +01:00
main = do
dbConnection <- initDB
2016-02-28 23:23:32 +01:00
let context = dbConnection :. EmptyContext
run 8080 (serveWithContext api context server)
2015-04-24 14:00:57 +02:00
{- 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.
2015-05-03 01:53:38 +02:00
-}