Instances.hs

{-# LANGUAGE OverloadedStrings     #-}

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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.Wai

import Web.Cookie



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

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

    route Proxy context subserver = WithRequest $ \request ->
        route (Proxy :: Proxy sublayout) context (addCapture subserver $ do
            let mbCookieHeaders = lookup "cookie" (requestHeaders request)
                mbSessionIdText = lookup "session" =<< fmap parseCookiesText mbCookieHeaders

            pure $ case mbSessionIdText of
                Nothing -> FailFatal err401
                Just sessionIdText -> case parseQueryParam sessionIdText of
                    Left _ -> FailFatal err401
                    Right sId -> Route $ (SessionIdCredential $ SessionId sId)
        )



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

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

    route Proxy context subserver = WithRequest $ \request ->
        route (Proxy :: Proxy sublayout) context (addCapture subserver $ do
            let mbCookieHeaders = lookup "cookie" (requestHeaders request)
                mbSessionIdText = lookup "session" =<< fmap parseCookiesText mbCookieHeaders

            pure $ case mbSessionIdText of
                Nothing -> FailFatal err401
                Just sessionIdText -> case parseQueryParam sessionIdText of
                    Left _ -> FailFatal err401
                    Right sId -> Route $ SessionId sId
        )


instance ToByteString SetCookie where
    builder = renderSetCookie