RequiredHeader.hs

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE PolyKinds          #-}
{-# LANGUAGE TypeOperators      #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
{-# LANGUAGE TypeFamilies    #-}
{-# LANGUAGE ScopedTypeVariables #-}

module RequiredHeader (RequiredHeader) where

import Data.Aeson (ToJSON)
import Data.ByteString (ByteString)
import Data.String (fromString)
import Data.Typeable

import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

import Network.Wai (Request, requestHeaders)

import Servant.API ((:>))
import Servant.Server (HasServer(..), ServerT, ServantErr, err400)
import Servant.Server.Internal.RoutingApplication ( RouteResult(Fail)
                                                  , Delayed(..), serverD)

import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe)


data RequiredHeader (sym :: Symbol) a = RequiredHeader a
                                      | MissingRequiredHeader
                                      | UndecodableRequiredHeader ByteString
                                      deriving (Typeable, Eq, Show, Functor)

instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
      => HasServer (RequiredHeader sym a :> api) context where

    type ServerT (RequiredHeader sym a :> api) m =
      a -> ServerT api m

    route Proxy context subserver =
        let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
            str = fromString $ symbolVal (Proxy :: Proxy sym)
         in route (Proxy :: Proxy api) context
                (passToServerWithFail err400 subserver mheader)

-- | Like `passToServer` but with failure.
passToServerWithFail :: ServantErr -> Delayed env (a -> b)
                     -> (Request -> Maybe a) -> Delayed env b
passToServerWithFail e Delayed{..} f =
  Delayed
    { serverD = \ c p a b req ->
        case f req of
            Nothing -> Fail e
            Just x -> ($ x) <$> serverD c p a b req
    , ..
    }

servant and servant-server >= 0.10