diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.15 +---- + +- First release with support for `servant-0.15` `Stream` refactoring. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Servant Contributors + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Servant Contributors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,98 @@ +{-# 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.Streaming +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" diff --git a/servant-machines.cabal b/servant-machines.cabal new file mode 100644 --- /dev/null +++ b/servant-machines.cabal @@ -0,0 +1,63 @@ +cabal-version: >=1.10 +name: servant-machines +version: 0.15 + +synopsis: Servant Stream support for machines +category: Servant, Web, Enumerator +description: Servant Stream support for machines. + . + Provides 'ToSourceIO' and 'FromSourceIO' instances for 'MachineT'. + +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant/issues +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2018 Servant Contributors +build-type: Simple +tested-with: + GHC ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.2 + +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: http://github.com/haskell-servant/servant-machines.git + +library + exposed-modules: Servant.Machines + build-depends: + base >=4.9 && <5 + , bytestring >=0.10.8.1 && <0.11 + , machines >=0.6.4 && <0.7 + , mtl >=2.2.2 && <2.3 + , servant >=0.15 && <0.16 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite example + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + example + ghc-options: -Wall -rtsopts -threaded + build-depends: + base + , base-compat + , bytestring + , http-media + , servant + , machines + , servant-machines + , servant-server >=0.15 && <0.16 + , servant-client >=0.15 && <0.16 + , wai >=3.2.1.2 && <3.3 + , warp >=3.2.25 && <3.3 + , http-client + default-language: Haskell2010 diff --git a/src/Servant/Machines.hs b/src/Servant/Machines.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Machines.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'MachineT' instances. +module Servant.Machines ( + MachineToSourceIO (..), + ) where + +import Control.Monad.IO.Class + (MonadIO (..)) +import Data.Machine + (MachineT (..), Step (..)) +import Servant.API.Stream +import qualified Servant.Types.SourceT as S + +-- | Helper class to implement @'ToSourceIO' 'MachineT'@ instance +-- for various monads. +class MachineToSourceIO m where + machineToSourceIO :: MachineT m k o -> S.SourceT IO o + +instance MachineToSourceIO IO where + machineToSourceIO ma = S.SourceT ($ go ma) where + go (MachineT m) = S.Effect $ do + step <- m + case step of + Stop -> return S.Stop + Yield x m' -> return (S.Yield x (go m')) + Await _ _ m' -> return (S.Skip (go m')) + +instance MachineToSourceIO m => ToSourceIO o (MachineT m k o) where + toSourceIO = machineToSourceIO + +instance MonadIO m => FromSourceIO o (MachineT m k o) where + fromSourceIO src = MachineT $ liftIO $ S.unSourceT src go + where + go :: S.StepT IO o -> IO (Step k o (MachineT m k o)) + go S.Stop = return Stop + go (S.Error err) = fail err + go (S.Skip s) = go s + go (S.Effect ms) = ms >>= go + go (S.Yield x s) = return (Yield x (MachineT (liftIO (go s)))) + {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> MachineT IO k o #-}