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
|
main-is: Main.hs
|
||||||
other-modules: Schema
|
other-modules: Schema
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall -fprint-potential-instances
|
||||||
build-depends:
|
build-depends:
|
||||||
async >=2.2 && <3
|
async >=2.2 && <3
|
||||||
, base >=4.12 && <5
|
, base >=4.12 && <5
|
||||||
@ -49,6 +50,7 @@ executable seed-server-optics
|
|||||||
main-is: Optics.hs
|
main-is: Optics.hs
|
||||||
other-modules: Schema
|
other-modules: Schema
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall -fprint-potential-instances
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.12 && <5
|
base >=4.12 && <5
|
||||||
, conduit >=1.3.2 && <2
|
, conduit >=1.3.2 && <2
|
||||||
@ -62,4 +64,22 @@ executable seed-server-optics
|
|||||||
, stm >=2.5 && <3
|
, stm >=2.5 && <3
|
||||||
, text >=1.2 && <2
|
, 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
|
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