{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Linnet.Bootstrap
( bootstrap
, serve
, compile
, toApp
) where
import Control.Monad.Catch (throwM)
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Writer.Lazy (runWriterT)
import qualified Linnet.Compile as Compile
import Linnet.Endpoint
import Linnet.Internal.Coproduct ((:+:), CNil)
import Linnet.Internal.HList (HList (..))
import Linnet.NaturalTransformation
import Network.Wai (Application)
newtype Bootstrap (m :: * -> *) cts es =
Bootstrap es
bootstrap :: forall ct m a. Endpoint m a -> Bootstrap m (ct :+: CNil) (HList '[ (Endpoint m a)])
bootstrap ea = Bootstrap @m @(ct :+: CNil) (ea ::: HNil)
serve ::
forall ct cts es m a.
Endpoint m a
-> Bootstrap m cts (HList es)
-> Bootstrap m (ct :+: cts) (HList (Endpoint m a ': es))
serve ea (Bootstrap e) = Bootstrap @m @(ct :+: cts) (ea ::: e)
compile ::
forall cts m es. (Compile.Compile cts m es)
=> Bootstrap m cts es
-> Compile.Compiled m
compile (Bootstrap e) = Compile.compile @cts @m e
toApp ::
forall m. (NaturalTransformation m IO)
=> Compile.Compiled m
-> Application
toApp !readerT request callback = mapK (runWriterT $ runReaderT readerT request) >>= process . fst
where
process (Right response) = callback response
process (Left err) = throwM err