{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Linnet.Compile
( Compile(..)
, Compiled
) where
import Control.Exception (SomeException)
import Control.Monad (join, (>=>))
import Control.Monad.Catch (MonadCatch, catchAll)
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Trans (lift)
import Control.Monad.Writer.Lazy (WriterT (..))
import Data.ByteString (intercalate)
import Data.ByteString.Char8 (split)
import Data.Maybe (maybeToList)
import Linnet.Endpoint (Endpoint (..), EndpointResult (..),
NotMatchedReason (..), Trace,
handle)
import Linnet.Errors (LinnetError)
import Linnet.Input
import Linnet.Internal.Coproduct
import Linnet.Internal.HList
import Linnet.Output (Output (..), outputToResponse,
payloadError)
import Linnet.ToResponse (Negotiable (..))
import Network.HTTP.Media (MediaType, parseQuality)
import Network.HTTP.Types (Method, badRequest400, hAccept,
methodNotAllowed405, notFound404)
import Network.HTTP.Types.Header (hAllow)
import Network.Wai (Request, Response, requestHeaders,
responseLBS)
newtype CompileContext =
CompileContext
{ allowedMethods :: [Method]
}
type Compiled m = ReaderT Request (WriterT Trace m) (Either SomeException Response)
class Compile cts m es where
compile :: es -> Compiled m
compile es = compileWithContext @cts es (CompileContext [])
compileWithContext :: es -> CompileContext -> Compiled m
instance (Monad m) => Compile CNil m (HList '[]) where
compileWithContext _ CompileContext {..} =
ReaderT $
const
(if null allowedMethods
then lift $ Right <$> notFoundResponse
else lift $ Right <$> methodNotAllowedResponse allowedMethods)
instance (Negotiable ct a, Negotiable ct SomeException, Negotiable ct (), Compile cts m (HList es), MonadCatch m) =>
Compile (ct :+: cts) m (HList (Endpoint m a ': es)) where
compileWithContext ((ea :: Endpoint m a) ::: es) ctx@CompileContext {..} =
ReaderT
(\req ->
let accept =
(maybeToList . lookup hAccept >=> split ',' >=> (join . maybeToList . parseQuality @MediaType)) .
requestHeaders $
req
in case runEndpoint (handle respond400 ea) (inputFromRequest req) of
Matched {..} ->
WriterT $
(, matchedTrace) <$>
catchAll
(Right .
outputToResponse
(negotiate @ct accept Nothing)
(negotiate @ct accept Nothing)
(negotiate @ct accept Nothing) <$>
matchedOutput)
(pure . Left)
NotMatched r ->
let newContext =
case r of
MethodNotAllowed allowed -> ctx {allowedMethods = allowed : allowedMethods}
Other -> ctx
in runReaderT (compileWithContext @cts es newContext) req)
notFoundResponse :: (Applicative m) => m Response
notFoundResponse = pure $ responseLBS notFound404 [] mempty
methodNotAllowedResponse :: (Applicative m) => [Method] -> m Response
methodNotAllowedResponse wouldAllow = pure $ responseLBS methodNotAllowed405 [(hAllow, headerValue)] mempty
where
headerValue = intercalate ", " wouldAllow
respond400 :: (Applicative m) => LinnetError -> m (Output a)
respond400 err = pure $ payloadError badRequest400 err