Instances.hs

{-# LANGUAGE OverloadedStrings   #-}

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE TypeOperators       #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Avers.Server.Instances where


import Data.Proxy
import Data.ByteString.Conversion

import Avers
import Avers.API

import Servant.API
import Servant.Server
import Servant.Server.Internal

import Network.HTTP.Types.Status

import Network.Wai

import Web.Cookie



instance (HasServer sublayout) => HasServer (Credentials :> sublayout) where

    type ServerT (Credentials :> sublayout) m =
        Credentials -> ServerT sublayout m

    route Proxy subserver request respond = do
        let mbCookieHeaders = lookup "cookie" (requestHeaders request)
            mbSessionIdText = fromText =<< lookup "session" =<< fmap parseCookiesText mbCookieHeaders
            mbCredentials   = fmap (SessionIdCredential . SessionId) mbSessionIdText

        case mbCredentials of
            Nothing -> respond $ RR $ Right $ responseLBS status401 [] ""
            Just cred -> route (Proxy :: Proxy sublayout) (subserver cred) request respond



instance (HasServer sublayout) => HasServer (SessionId :> sublayout) where

    type ServerT (SessionId :> sublayout) m =
        SessionId -> ServerT sublayout m

    route Proxy subserver request respond = do
        let mbCookieHeaders = lookup "cookie" (requestHeaders request)
            mbSessionIdText = fromText =<< lookup "session" =<< fmap parseCookiesText mbCookieHeaders
            mbSessionId     = fmap SessionId mbSessionIdText

        case mbSessionId of
            Nothing -> respond $ RR $ Right $ responseLBS status401 [] ""
            Just sId -> route (Proxy :: Proxy sublayout) (subserver sId) request respond


instance ToByteString SetCookie where
    builder = renderSetCookie