Compile.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module Linnet.Compile
  ( Compile(..)
  ) where

import           Control.Exception         (SomeException)
import           Control.Monad.Catch       (MonadCatch)
import           Control.Monad.Reader      (ReaderT(..))
import           Data.Data                 (Proxy)
import           GHC.TypeLits              (KnownSymbol)
import           Linnet.Endpoint
import           Linnet.Errors             (LinnetError)
import           Linnet.Input
import           Linnet.Internal.Coproduct
import           Linnet.Internal.HList
import           Linnet.Output             (Output (..), outputToResponse,
                                            payloadError)
import           Linnet.ToResponse         (ToResponse)
import           Network.HTTP.Types        (badRequest400, status404)
import           Network.Wai               (Request, Response, responseLBS)

class Compile cts m es where
  compile :: es -> ReaderT Request m Response

instance (Monad m) => Compile CNil m (HList '[]) where
  compile _ = ReaderT $ const notFoundResponse

instance (KnownSymbol ct, ToResponse ct a, ToResponse ct SomeException, Compile cts m (HList es), MonadCatch m) =>
         Compile (Coproduct (Proxy ct) cts) m (HList (Endpoint m a ': es)) where
  compile (ea ::: es) =
    ReaderT
      (\req ->
         case runEndpoint (handle respond400 ea) (inputFromRequest req) of
           Matched _ mo -> outputToResponse @a @ct <$> mo
           NotMatched   -> runReaderT (compile @cts es) req)

notFoundResponse :: (Applicative m) => m Response
notFoundResponse = pure $ responseLBS status404 [] mempty

respond400 :: (Applicative m) => LinnetError -> m (Output a)
respond400 err = pure $ payloadError badRequest400 err