Skip to content

Instantly share code, notes, and snippets.

@hlian
Last active Apr 24, 2021
Embed
What would you like to do?
let's build a servant
{-# 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)
{-# 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)
{-# 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