Last active
April 24, 2021 06:39
-
-
Save hlian/c90b9b7bf845255292fb65d41f43ad21 to your computer and use it in GitHub Desktop.
let's build a servant
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE TypeFamilies #-} | |
module Main where | |
import Data.Text (Text) | |
import Network.HTTP.Types (status200) | |
import Network.Wai (Application, responseLBS) | |
import Network.Wai.Handler.Warp (run) | |
import Data.Aeson | |
import Data.Aeson.TH | |
data Be a | |
data User = | |
User { hopes :: [Text] , fears :: [Text] } | |
-- | The type of our RESTful service | |
type API = | |
Be [User] | |
-- | ToJSON and FromJSON instances for our model type | |
deriveJSON defaultOptions ''User | |
-- | Monadic function implements the service | |
imp :: IO [User] | |
imp = | |
return [ User ["ketchup", "eggs"] ["xenophobia", "reactionaries"] | |
, User ["oldies", "punk"] ["half-tries", "equivocation"] | |
] | |
-- | Marrying type and function to produce an Application | |
serve :: ToJSON a => Be a -> IO a -> Application | |
serve _ contentM = \request respond -> do | |
content <- contentM | |
respond . responseLBS status200 [] . encode $ content | |
main :: IO () | |
main = | |
run 2016 (serve undefined imp) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE PolyKinds #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
module Main where | |
import Data.Proxy (Proxy(..)) | |
import Data.Text (Text) | |
import GHC.TypeLits (KnownSymbol, symbolVal) | |
import Network.HTTP.Types (status200) | |
import Network.Wai (Application, responseLBS, pathInfo) | |
import Network.Wai.Handler.Warp (run) | |
import Control.Lens | |
import Control.Monad.Catch | |
import Data.Aeson | |
import Data.Aeson.TH | |
import Data.Text.Strict.Lens | |
data RoutingFailure = | |
RoutingFailure | |
deriving (Show) | |
data Be a | |
data path :> rest | |
infixr 9 :> | |
data left :<|> right = | |
left :<|> right | |
infixr 8 :<|> | |
data User = | |
User { hopes :: [Text] , fears :: [Text] } | |
-- | The type of our RESTful service | |
type API = | |
"users" :> Be [User] | |
:<|> "temperature" :> Be Int | |
-- | ToJSON and FromJSON instances for our model type | |
deriveJSON defaultOptions ''User | |
instance Exception RoutingFailure where | |
-- | Two monadic functions glued together implement the service | |
imp :: IO [User] :<|> IO Int | |
imp = | |
users :<|> temperature | |
where | |
users = | |
return [ User ["ketchup", "eggs"] ["xenophobia", "reactionaries"] | |
, User ["oldies", "punk"] ["half-tries", "equivocation"] | |
] | |
temperature = | |
return 72 | |
class ToApplication api where | |
type Content api | |
serve :: api -> Content api -> Application | |
instance ToJSON a => ToApplication (Be a) where | |
type Content (Be a) = IO a | |
serve _ contentM = \request respond -> do | |
content <- contentM | |
respond . responseLBS status200 [] . encode $ content | |
instance (KnownSymbol path, ToApplication rest) => ToApplication (path :> rest) where | |
type Content (path :> rest) = Content rest | |
serve _ contentM = \request respond -> do | |
case pathInfo request of | |
(first:pathInfoTail) | |
| view unpacked first == symbolVal (Proxy :: Proxy path) -> do | |
let subrequest = request { pathInfo = pathInfoTail } | |
serve (undefined :: rest) contentM subrequest respond | |
_ -> | |
throwM RoutingFailure | |
instance (ToApplication left, ToApplication right) => ToApplication (left :<|> right) where | |
type Content (left :<|> right) = Content left :<|> Content right | |
serve _ (leftM :<|> rightM) = \request respond -> do | |
let handler (_ :: RoutingFailure) = | |
serve (undefined :: right) rightM request respond | |
catch (serve (undefined :: left) leftM request respond) handler | |
main :: IO () | |
main = | |
run 2016 (serve (undefined :: API) imp) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE PolyKinds #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE UndecidableInstances #-} | |
module Main where | |
import Data.ByteString (ByteString) | |
import Data.Proxy (Proxy(..)) | |
import Data.Text (Text) | |
import GHC.TypeLits (KnownSymbol, symbolVal) | |
import Network.HTTP.Types (status200, status406) | |
import Network.Wai (Application, responseLBS, pathInfo, requestHeaders) | |
import Network.Wai.Handler.Warp (run) | |
import Control.Applicative | |
import Control.Lens | |
import Control.Monad.Catch | |
import Data.Aeson | |
import Data.Aeson.TH | |
import Data.Text.Strict.Lens | |
data RoutingFailure = | |
RoutingFailure | |
deriving (Show) | |
data Be (contentTypes :: [*]) a | |
data English | |
data Haskell | |
data JSON | |
data path :> rest | |
infixr 9 :> | |
data left :<|> right = | |
left :<|> right | |
infixr 8 :<|> | |
data User = | |
User { hopes :: [Text] , fears :: [Text] } | |
deriving (Show) | |
-- | The type of our RESTful service | |
type API = | |
"users" :> Be [JSON, Haskell] [User] | |
:<|> "temperature" :> Be [JSON, English] Int | |
-- | ToJSON and FromJSON instances for our model type | |
deriveJSON defaultOptions ''User | |
instance Exception RoutingFailure where | |
-- | Two monadic functions glued together implement the service | |
imp :: IO [User] :<|> IO Int | |
imp = | |
users :<|> temperature | |
where | |
users = | |
return [ User ["ketchup", "eggs"] ["xenophobia", "reactionaries"] | |
, User ["oldies", "punk"] ["half-tries", "equivocation"] | |
] | |
temperature = | |
return 72 | |
class ToApplication api where | |
type Content api | |
serve :: api -> Content api -> Application | |
class ToBody (gives :: [*]) a where | |
toBody :: Proxy gives -> [ByteString] -> a -> Maybe ByteString | |
instance ToBody '[] a where | |
toBody Proxy _ _ = Nothing | |
instance (Give first a, ToBody rest a) => ToBody (first ': rest) a where | |
toBody Proxy accepted value = | |
give (Proxy :: Proxy first) accepted value | |
<|> toBody (Proxy :: Proxy rest) accepted value | |
class Give give a where | |
give :: Proxy give -> [ByteString] -> a -> Maybe ByteString | |
instance ToJSON a => Give JSON a where | |
give Proxy accepted value = | |
if elem "application/json" accepted then | |
Just (view strict (encode value)) | |
else | |
Nothing | |
instance (a ~ Int) => Give English a where | |
give Proxy accepted value = | |
if elem "text/english" accepted then | |
Just (toEnglish value) | |
else | |
Nothing | |
where | |
toEnglish 0 = "zero" | |
toEnglish 1 = "one" | |
toEnglish 2 = "two" | |
toEnglish 72 = "seventy two" | |
toEnglish _ = "lots" | |
instance Show a => Give Haskell a where | |
give Proxy accepted value = | |
if elem "text/haskell" accepted then | |
Just (view (packed . re utf8) (show value)) | |
else | |
Nothing | |
instance (ToBody gives a) => ToApplication (Be gives a) where | |
type Content (Be gives a) = IO a | |
serve _ contentM = \request respond -> do | |
content <- contentM | |
let accepts = [value | ("accept", value) <- requestHeaders request] | |
case toBody (Proxy :: Proxy gives) accepts content of | |
Just bytes -> | |
respond (responseLBS status200 [] (view lazy bytes)) | |
Nothing -> | |
respond (responseLBS status406 [] "bad accept header") | |
instance (KnownSymbol path, ToApplication rest) => ToApplication (path :> rest) where | |
type Content (path :> rest) = Content rest | |
serve _ contentM = \request respond -> do | |
case pathInfo request of | |
(first:pathInfoTail) | |
| view unpacked first == symbolVal (Proxy :: Proxy path) -> do | |
let subrequest = request { pathInfo = pathInfoTail } | |
serve (undefined :: rest) contentM subrequest respond | |
_ -> | |
throwM RoutingFailure | |
instance (ToApplication left, ToApplication right) => ToApplication (left :<|> right) where | |
type Content (left :<|> right) = Content left :<|> Content right | |
serve _ (leftM :<|> rightM) = \request respond -> do | |
let handler (_ :: RoutingFailure) = | |
serve (undefined :: right) rightM request respond | |
catch (serve (undefined :: left) leftM request respond) handler | |
main :: IO () | |
main = | |
run 2016 (serve (undefined :: API) imp) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment