servant-auth2.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Lib
    ( startApp
    , app
    ) where

import Data.Typeable
import Data.Aeson
import Data.Aeson.TH
import Control.Monad.IO.Class
import Control.Monad.Except
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Servant.Server.Internal.RoutingApplication
    (addAuthCheck, delayedFailFatal, DelayedIO, withRequest)
  
data User = User
  { userId        :: Int
  , userFirstName :: String
  , userLastName  :: String
  } deriving (Eq, Show)

$(deriveJSON defaultOptions ''User)

type API =
    WithUser :> (
        "foo" :> Get '[JSON] [User]   :<|>
        "bar" :> Get '[JSON] [User]
    )

startApp :: IO ()
startApp = run 8080 app

app :: Application
app = serve api server

api :: Proxy API
api = Proxy

server :: Server API
server = \user -> do -- Here I'm not using 'user' but I could if I wanted to
  return users
  :<|>
  return users

users :: [User]
users = [ User 1 "Isaac" "Newton"
        , User 2 "Albert" "Einstein"
        ]

----------------------------------------------------------------------------
-- WithUser
----------------------------------------------------------------------------

data WithUser deriving (Typeable)

instance HasLink sub => HasLink (WithUser :> sub) where
  type MkLink (WithUser :> sub) = MkLink sub
  toLink _ = toLink (Proxy :: Proxy sub)

instance ( HasServer api context
         )
  => HasServer (WithUser :> api) context where

  type ServerT (WithUser :> api) m =
    User -> ServerT api m

  route Proxy context subserver =
      route (Proxy :: Proxy api) context
          (subserver `addAuthCheck` withRequest authCheck)
      where
        authHandler :: Request -> Handler User
        authHandler = undefined -- get your user here
        authCheck :: Request -> DelayedIO User
        authCheck = (>>= either delayedFailFatal return) . liftIO .
                    runExceptT . authHandler