99 lines
3.1 KiB
Haskell
99 lines
3.1 KiB
Haskell
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE DeriveGeneric #-}
|
||
|
|
{-# LANGUAGE TypeOperators #-}
|
||
|
|
module Main (main) where
|
||
|
|
|
||
|
|
import Prelude ()
|
||
|
|
import Prelude.Compat
|
||
|
|
|
||
|
|
import Control.Concurrent
|
||
|
|
(threadDelay)
|
||
|
|
import Control.Monad.IO.Class
|
||
|
|
(MonadIO (..))
|
||
|
|
import qualified Data.ByteString as BS
|
||
|
|
import Data.Maybe
|
||
|
|
(fromMaybe)
|
||
|
|
import Data.Void
|
||
|
|
(Void)
|
||
|
|
import Network.HTTP.Client
|
||
|
|
(defaultManagerSettings, newManager)
|
||
|
|
import Network.Wai
|
||
|
|
(Application)
|
||
|
|
import System.Environment
|
||
|
|
(getArgs, lookupEnv)
|
||
|
|
import Text.Read
|
||
|
|
(readMaybe)
|
||
|
|
|
||
|
|
import Data.Machine
|
||
|
|
import Servant
|
||
|
|
import Servant.Client
|
||
|
|
import Servant.Machines ()
|
||
|
|
|
||
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
||
|
|
|
||
|
|
type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (MachineT IO (Is Void) Int)
|
||
|
|
|
||
|
|
type API = FastAPI
|
||
|
|
:<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (MachineT IO (Is Void) Int)
|
||
|
|
:<|> "proxy"
|
||
|
|
:> StreamBody NoFraming OctetStream (MachineT IO (Is Void) BS.ByteString)
|
||
|
|
:> StreamPost NoFraming OctetStream (MachineT IO (Is Void) BS.ByteString)
|
||
|
|
|
||
|
|
api :: Proxy API
|
||
|
|
api = Proxy
|
||
|
|
|
||
|
|
server :: Server API
|
||
|
|
server = fast :<|> slow :<|> proxy
|
||
|
|
where
|
||
|
|
fast n = liftIO $ do
|
||
|
|
putStrLn ("/get/" ++ show n)
|
||
|
|
return $ fastMachine n
|
||
|
|
|
||
|
|
slow n = liftIO $ do
|
||
|
|
putStrLn ("/slow/" ++ show n)
|
||
|
|
return $ slowMachine n
|
||
|
|
|
||
|
|
proxy c = liftIO $ do
|
||
|
|
putStrLn "/proxy"
|
||
|
|
return c
|
||
|
|
|
||
|
|
-- for some reason unfold leaks?
|
||
|
|
fastMachine m
|
||
|
|
| m < 0 = MachineT (return Stop)
|
||
|
|
| otherwise = MachineT (return (Yield m (fastMachine (m - 1))))
|
||
|
|
|
||
|
|
slowMachine m
|
||
|
|
| m < 0 = MachineT (return Stop)
|
||
|
|
| otherwise = MachineT $ do
|
||
|
|
threadDelay 1000000
|
||
|
|
return (Yield m (slowMachine (m - 1)))
|
||
|
|
|
||
|
|
app :: Application
|
||
|
|
app = serve api server
|
||
|
|
|
||
|
|
cli :: Client ClientM FastAPI
|
||
|
|
cli :<|> _ = client api
|
||
|
|
|
||
|
|
main :: IO ()
|
||
|
|
main = do
|
||
|
|
args <- getArgs
|
||
|
|
case args of
|
||
|
|
("server":_) -> do
|
||
|
|
putStrLn "Starting servant-machines:example at http://localhost:8000"
|
||
|
|
port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
|
||
|
|
Warp.run port app
|
||
|
|
("client":ns:_) -> do
|
||
|
|
n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns
|
||
|
|
mgr <- newManager defaultManagerSettings
|
||
|
|
burl <- parseBaseUrl "http://localhost:8000/"
|
||
|
|
withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of
|
||
|
|
Left err -> print err
|
||
|
|
Right m -> do
|
||
|
|
x <- runT $ fold (\p _ -> p + 1) (0 :: Int) <~ m
|
||
|
|
print x
|
||
|
|
_ -> do
|
||
|
|
putStrLn "Try:"
|
||
|
|
putStrLn "cabal new-run servant-machines:example server"
|
||
|
|
putStrLn "cabal new-run servant-machines:example client 10"
|
||
|
|
putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"
|