Трубы и ответвления Haskell

я пытаюсь реализовать простой веб-сервер с Haskell и библиотеки трубы. Теперь я понимаю, что циклические или алмазные топологии невозможны с трубами, однако я думал, что я пытаюсь это сделать. Моя желаемая топология такова:

                                 -GET--> handleGET >-> packRequest >-> socketWriteD
                                 |
socketReadS >-> parseRequest >-routeRequest
                                 |
                                 -POST-> handlePOST >-> packRequest >-> socketWriteD

я HTTPRequest RequestLine Headers Message и HTTPResponse StatusLine Headers Message типы, которые используются в цепочке. socketReadS берет байты из сокета и пересылает их в parseRequest, который использует Attoparsec для анализа байтов в HTTPRequest объект. Затем я хотел бы, чтобы канал разветвлялся по крайней мере дважды и, возможно, больше в зависимости от того, сколько HTTP-методов я реализую. Каждый handle<method> функция должна получать HTTPRequest объекты вверх и вперед HTTPResponse объекты packRequest, который просто упаковывает объекты HTTPResponse в ByteString готов к отправке с socketWriteS.

следующий код typechecks, если я позволю GHC вывести тип для routeRequest''' (мой, кажется, немного не то). Однако ничего не кажется выполнение после parseRequest. Кто-нибудь может помочь мне понять почему?

код

у меня есть следующий код routeRequest который должен обрабатывать ветвление.

routeRequest''' ::
    (Monad m, Proxy p1, Proxy p2, Proxy p3)
    => () -> Consumer p1 HTTPRequest (Pipe p2 HTTPRequest HTTPRequest (Pipe p3 HTTPRequest HTTPRequest m)) r
routeRequest''' () = runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ forever $ do
    httpReq <- request ()
    let method = getMethod httpReq
    let (URI uri) = getURI httpReq
    case method of
      GET -> lift $ respond httpReq
      POST -> lift $ lift $ respond httpReq

routeRequest'' = runProxyK $ routeRequest''' <-< unitU
routeRequest' socket = runProxyK $ raiseK (p4 socket <-< handleGET) <-< routeRequest''
routeRequest socket = (p4 socket <-< handlePOST) <-< (routeRequest' socket)

handleGET и handlePOST реализованы как таковые:

handleGET :: Proxy p => () -> p () HTTPRequest r ByteString IO r
handleGET () = runIdentityP $ do
    httpReq <- request ()
    let (URI uri) = getURI httpReq
    lift $ Prelude.putStrLn "GET"
    respond $ B.append (B.pack "GET ") uri


handlePOST :: Proxy p => () -> p () HTTPRequest r ByteString IO r
handlePOST () = runIdentityP $ do
    httpReq <- request ()
    let (URI uri) = getURI httpReq
    lift $ Prelude.putStrLn "POST"
    respond $ B.append (B.pack "POST ") uri

у меня есть следующие сокращения для прокси:

p1 socket = socketReadS 32 socket
p2 = parseRequestProxy 
p4 socket = socketWriteD socket

наконец, я запускаю все это так:

main = serveFork (Host "127.0.0.1") "8080" $
    (socket, remoteAddr) -> do
        ret <- runProxy $ runEitherK $ p1 socket >-> printD >-> p2 >-> printD  >-> routeRequest socket 
        Prelude.putStrLn $ show ret

тип подписи parseRequestProxy is это:

parseRequestProxy
  :: (Monad m, Proxy p) =>
     ()
     -> Pipe
          (EitherP Control.Proxy.Attoparsec.Types.BadInput p)
          ByteString
          HTTPRequest
          m
          r

редактировать

вот репозиторий с исходным кодом. Будьте осторожны, он не был приукрашен так использовать на свой страх и риск. https://bitbucket.org/Dwilson1234/haskell-web-server/overview

10
haskell haskell-pipes

2 ответов

я был неправ, когда изначально сказал, что вы не можете справиться с алмазными топологиями. Позже я обнаружил разумный способ сделать это, используя ArrowChoice - подобный интерфейс и включил решение в pipes-3.2.0 в форме leftD и rightD комбинаторы. Я объясню, как это работает:

вместо вложенности прокси-трансформаторов вы обертываете результат с помощью Left или Right

routeRequest ::
    (Monad m, Proxy p)
    => () -> Pipe p HTTPRequest (Either HTTPRequest HTTPRequest) m r
routeRequest () = runIdentityP $ forever $ do
    httpReq <- request ()
    let method = getMethod httpReq
    let (URI uri) = getURI httpReq
    respond $ case method of
      GET  -> Left  httpReq
      POST -> Right httpReq

затем вы можете выборочно применить каждый обработчик к каждой ветви, а затем объединить ветви:

routeRequest >-> leftD handleGET >-> rightD handlePOST >-> mapD (either id id)
    :: (Monad m, Proxy p) => () -> Pipe p HTTPRequest ByteString IO r

если у вас есть более двух ветвей, то вам придется гнездо Eithers, но это просто ограничение того, как ArrowChoice строительство.

8

Я не запускал ваш код, но я думаю, что заметил проблему.

routeRequest'' = runProxyK $ routeRequest''' <-< unitU

routeRequest''' запрашивает данные от unitU, которому нечего предоставить, поэтому он зависает.

:t runProxy $ unitU >-> printD

будет вводить check, но ничего не работает.

похоже, что данные отправляются на неправильный уровень трансформатора монады, данные, которые текут в routeRequest должно течь в routeRequest'''. Данные, поступающие на неправильный уровень трансформатора монады, - это то, что, вероятно в результате вам нужно оставить подпись типа, чтобы получить все, чтобы ввести проверку. С подписью типа routeRequest ждет () идя вверх по течению и, держу пари, без подписи типа разрешено быть полиморфным.

в определении routeRequest вы можете "закрыть трубу", я думаю, что это то, что называется, используя unitD, который запретит вашу конструкцию, даже когда routeRequest''' не имеет подписи типа.

1