mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-10-26 15:49:00 +03:00
Version of seed server using lenses
This commit is contained in:
parent
c92dfeb199
commit
871d702741
@ -29,6 +29,7 @@ executable seed-server
|
||||
main-is: Main.hs
|
||||
other-modules: Schema
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fprint-potential-instances
|
||||
build-depends:
|
||||
async >=2.2 && <3
|
||||
, base >=4.12 && <5
|
||||
@ -49,6 +50,7 @@ executable seed-server-optics
|
||||
main-is: Optics.hs
|
||||
other-modules: Schema
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fprint-potential-instances
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, conduit >=1.3.2 && <2
|
||||
@ -62,4 +64,22 @@ executable seed-server-optics
|
||||
, stm >=2.5 && <3
|
||||
, text >=1.2 && <2
|
||||
|
||||
executable seed-server-lens
|
||||
hs-source-dirs: src
|
||||
main-is: Lens.hs
|
||||
other-modules: Schema
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fprint-potential-instances
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, conduit >=1.3.2 && <2
|
||||
, lens
|
||||
, monad-logger >=0.3 && <0.4
|
||||
, mu-grpc-server >=0.4.0
|
||||
, mu-lens >=0.3.0
|
||||
, mu-protobuf >=0.4.0
|
||||
, mu-rpc >=0.4.0
|
||||
, mu-schema >=0.3.0
|
||||
, random >=1.1 && <2
|
||||
, stm >=2.5 && <3
|
||||
, text >=1.2 && <2
|
||||
|
77
examples/seed/src/Lens.hs
Normal file
77
examples/seed/src/Lens.hs
Normal file
@ -0,0 +1,77 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language OverloadedLabels #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PartialTypeSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Lens
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Combinators as C
|
||||
import Data.Text as T
|
||||
import Mu.GRpc.Server
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Lens
|
||||
import Mu.Server
|
||||
|
||||
import Schema
|
||||
|
||||
type Person = Term SeedSchema (SeedSchema :/: "Person")
|
||||
type PeopleRequest = Term SeedSchema (SeedSchema :/: "PeopleRequest")
|
||||
type PeopleResponse = Term SeedSchema (SeedSchema :/: "PeopleResponse")
|
||||
type Weather = Term SeedSchema (SeedSchema :/: "Weather")
|
||||
type WeatherRequest = Term SeedSchema (SeedSchema :/: "WeatherRequest")
|
||||
type WeatherResponse = Term SeedSchema (SeedSchema :/: "WeatherResponse")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "running seed application"
|
||||
runGRpcAppTrans msgProtoBuf 8080 runStderrLoggingT server
|
||||
|
||||
-- Server implementation
|
||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||
|
||||
server :: (MonadServer m, MonadLogger m) => SingleServerT info PeopleService m _
|
||||
server = singleService
|
||||
( method @"getPerson" getPerson
|
||||
, method @"getPersonStream" getPersonStream
|
||||
, method @"getWeather" getWeather )
|
||||
|
||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||
evolvePerson req = record (Just $ record (req ^. #name, 18))
|
||||
|
||||
getPerson :: Monad m => PeopleRequest -> m PeopleResponse
|
||||
getPerson = pure . evolvePerson
|
||||
|
||||
getPersonStream
|
||||
:: (MonadServer m, MonadLogger m)
|
||||
=> ConduitT () PeopleRequest m ()
|
||||
-> ConduitT PeopleResponse Void m ()
|
||||
-> m ()
|
||||
getPersonStream source sink = runConduit $ source .| C.mapM reStream .| sink
|
||||
where
|
||||
reStream req = do
|
||||
liftIO $ threadDelay (2 * 1000 * 1000) -- 2 sec
|
||||
logDebugN $ T.pack $ "stream request: " ++ show req
|
||||
pure $ evolvePerson req
|
||||
|
||||
getWeather :: (MonadServer m)
|
||||
=> WeatherRequest
|
||||
-> m WeatherResponse
|
||||
getWeather msg
|
||||
| Just w <- msg ^. #currentWeather
|
||||
= pure $ record (go w)
|
||||
| otherwise
|
||||
= pure $ record "who knows?"
|
||||
where go e | not $ e `isn't` #sunny = "is sunny! 😄"
|
||||
| not $ e `isn't` #cloudy = "is cloudy 😟"
|
||||
| not $ e `isn't` #rainy = "is rainy... 😭"
|
||||
| otherwise = error "this should never happen"
|
Loading…
Reference in New Issue
Block a user