Hacky way to get a servant app on an obelisk route.

Obelisk.Servant.hs

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeFamilies      #-}
module Obelisk.Servant where

import           Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import           Data.Bifunctor          (bimap)
import qualified Data.ByteString         as BS
import qualified Data.ByteString.Char8   as C8
import qualified Data.CaseInsensitive    as CI
import           Data.Foldable           (fold)
import qualified Data.Map                as Map
import           Data.Maybe              (maybe)
import           Data.Proxy              (Proxy)
import qualified Data.Text               as T
import qualified Data.Text.Encoding      as T
import qualified Data.Vault.Lazy         as Vault
import           Network.URI.Encode      (encodeTextToBS)
import qualified Network.HTTP.Types      as HTTP
import           Network.Socket          (AddrInfo, addrAddress, defaultHints,
                                          getAddrInfo)
import qualified Network.Wai             as W
import qualified Network.Wai.Internal    as W
import           Obelisk.Route           (PageName)
import           Servant.Server
import           Snap.Core
import qualified System.IO.Streams       as Streams

obeliskServant :: HasServer api '[] => Proxy api -> Server api -> PageName -> Snap ()
obeliskServant api server pageName = do
  let wapp = serve api server
  sreq <- getRequest
  wres <- runRequestBody $ \input -> do
    mvar <- newEmptyMVar
    addr:_ <- getAddrInfo Nothing (Just (C8.unpack $ rqClientAddr sreq)) Nothing
    _ <- wapp (toWaiRequest input addr pageName sreq) $ \wres' -> do
      putMVar mvar wres'
      pure W.ResponseReceived
    takeMVar mvar
  _ <- case wres of
    W.ResponseBuilder s hdrs b -> do
      modifyResponse
        $ setResponseStatus (HTTP.statusCode s) (HTTP.statusMessage $ s)
        . foldr (\(n,v) acc -> (setHeader n v) . acc) id hdrs
      writeBuilder b
    _                          -> error "Servant should only create a builder"
  pure ()

toWaiRequest :: Streams.InputStream BS.ByteString -> AddrInfo -> PageName -> Request -> W.Request
toWaiRequest input addr (pathParts,params) req = W.Request
  { W.requestMethod          = T.encodeUtf8 . T.pack . show . rqMethod $ req
  , W.httpVersion            = let (major,minor) = rqVersion req
                               in HTTP.HttpVersion major minor
  , W.rawPathInfo            = T.encodeUtf8 $ "/" <> (T.intercalate "/" pathParts)
  , W.rawQueryString         = if Map.null params
                               then ""
                               else "?" <>
                                ( BS.intercalate "&"
                                . fmap (\(k,v) -> (encodeTextToBS k) <> foldMap (("=" <>) . encodeTextToBS) v)
                                . Map.toList
                                $ params)
  , W.requestHeaders         = listHeaders req
  , W.isSecure               = rqIsSecure req
  , W.remoteHost             = addrAddress addr
  , W.pathInfo               = pathParts
  , W.queryString            = fmap (bimap T.encodeUtf8 (fmap T.encodeUtf8)) . Map.toList $ params
  , W.requestBody            = fold <$> Streams.read input
  , W.vault                  = Vault.empty
  , W.requestBodyLength      = maybe W.ChunkedBody W.KnownLength $ rqContentLength req
  , W.requestHeaderHost      = Just $ rqHostName req
  , W.requestHeaderRange     = getHeader (CI.mk "range") req
  , W.requestHeaderReferer   = getHeader (CI.mk "referer") req
  , W.requestHeaderUserAgent = getHeader (CI.mk "user-agent") req
}