servant-machines

Example.hs

{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators   #-}
{-# LANGUAGE OverloadedStrings   #-}
module Main (main) where

import Prelude        ()
import Prelude.Compat

import Control.Concurrent (threadDelay)
import Data.Maybe         (fromMaybe)
import Network.Wai        (Application)
import Data.Text
import Servant
import Servant.Machines
import System.Environment (getArgs, lookupEnv)
import Text.Read          (readMaybe)

import Data.Machine

import qualified Network.Wai.Handler.Warp as Warp

type API = MachineGet '[PlainText] Text

api :: Proxy API
api = Proxy

server :: Server API
server = SourceIO $ unfoldT f ()
  where
    f _ = do
      putStrLn "sleep"
      threadDelay 1000000
      return $ Just ("ping-asd-asd-asd-asd\n", ())

app :: Application
app = serve api server

main :: IO ()
main = do
    args <- getArgs
    case args of
        ("run":_) -> do
            port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
            putStrLn $ "http://localhost:" ++ show port ++ "/"
            Warp.run port app
        _ -> do
            putStrLn "Example application, used as a compilation check"
            putStrLn "To run, pass run argument: --test-arguments run"

Machines.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
-- |
-- Module      :  Servant.Machines
-- License     :  BSD-3-Clause
-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>
--
module Servant.Machines where

import Network.HTTP.Types.Status                  (status200)
import Network.Wai
import Servant
import Servant.API
       (Accept (..), MimeRender (..), MimeUnrender (..))
import Servant.API.ContentTypes
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication

import Data.Machine

import qualified Data.ByteString.Lazy as LBS
import qualified Network.HTTP.Media   as M
import qualified Data.ByteString.Builder as Builder

data MachineGet :: [*] -> * -> *

newtype SourceIO a = SourceIO { runSourceIO :: forall k. MachineT IO k a }

instance
    ( AllCTRender ctypes a
    )
    => HasServer (MachineGet ctypes a) context
  where
    type ServerT (MachineGet ctypes a) m = SourceIO a

    route Proxy _ source = RawRouter $ \ env request respond -> do
        r <- runDelayed source env request
        case r of
            Route (SourceIO machine) ->
                respond $ Route $ responseStream status200 [] streamingBody
              where
                streamingBody wr fl =
                    runT_ $ machine ~> sink
                  where
                    sink :: MachineT IO (Is a) ()
                    sink = MachineT . return $ Await f Refl stopped
                      where
                        f :: a -> MachineT IO (Is a) ()
                        f x = MachineT $ do
                            let Just (_, bs) = handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader "*/*") x
                            wr $ Builder.lazyByteString bs
                            fl
                            return $ Await f Refl stopped
            Fail a                   -> respond $ Fail a
            FailFatal e                -> respond $ FailFatal e