eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

reorganize everything into a sane(r) module structure

Browse source
This commit is contained in:
Alp Mestanogullari 2014-10-25 01:27:39 +02:00
parent 50f5c36727
commit d838191ec8
15 changed files with 556 additions and 419 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
example/greet.hs Normal file
View file

@ -0,0 +1,74 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent (forkIO, killThread)
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Monoid
import Data.Proxy
import Data.Text
import GHC.Generics
import Network.URI
import Network.Wai
import Network.Wai.Handler.Warp
import Servant.API
import Servant.Client
import Servant.Server
-- * Example
data Greet = Greet { msg :: Text }
deriving (Generic, Show)
instance FromJSON Greet
instance ToJSON Greet
-- API specification
type TestApi =
"hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
:<|> "greet" :> RQBody Greet :> Post Greet
testApi :: Proxy TestApi
testApi = Proxy
-- Server-side handlers
server :: Server TestApi
server = hello :<|> greet
where hello name Nothing = hello name (Just False)
hello name (Just False) = return . Greet $ "Hello, " <> name
hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name
greet = return
-- Client-side query functions
clientApi :: Client TestApi
clientApi = client testApi
getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
postGreet :: Greet -> URI -> EitherT String IO Greet
getGreet :<|> postGreet = clientApi
-- Turn the server into a WAI app
test :: Application
test = serve testApi server
-- Run the server
runTestServer :: Port -> IO ()
runTestServer port = run port test
-- Run some queries against the server
main :: IO ()
main = do
tid <- forkIO $ runTestServer 8001
let Just uri = parseURI "http://localhost:8001"
print =<< runEitherT (getGreet "alp" (Just True) uri)
print =<< runEitherT (getGreet "alp" (Just False) uri)
let g = Greet "yo"
print =<< runEitherT (postGreet g uri)
killThread tid

37
servant.cabal
View file

@ -4,7 +4,7 @@ version: 0.2
-- description:
license: BSD3
license-file: LICENSE
author: Alp Mestanogullari
author: Alp Mestanogullari, Soenke Hahn
maintainer: alpmestan@gmail.com
-- copyright:
category: Web
@ -13,7 +13,19 @@ build-type: Simple
cabal-version: >=1.10
library
exposed-modules: Servant Soenke
exposed-modules:
Servant
Servant.Client
Servant.Server
Servant.Text
Servant.API
Servant.API.Capture
Servant.API.Get
Servant.API.GetParam
Servant.API.Post
Servant.API.RQBody
Servant.API.Sub
Servant.API.Union
-- other-modules:
-- other-extensions:
build-depends:
@ -30,6 +42,21 @@ library
, warp
, transformers
, text
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -O2
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -O0 -Wall
executable greet
main-is: greet.hs
hs-source-dirs: example
ghc-options: -O0 -Wall
default-language: Haskell2010
build-depends:
base
, servant
, aeson
, warp
, wai
, either
, text
, network-uri

211
src/Servant.hs
View file

@ -1,202 +1,11 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant where
module Servant
( module Servant.API
, module Servant.Client
, module Servant.Server
, module Servant.Text
) where
import Control.Applicative
import Control.Concurrent (forkIO, killThread)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Monoid
import Data.Proxy
import Data.String.Conversions
import Data.Text
import GHC.Generics
import GHC.TypeLits
import Network.HTTP.Types
import Network.URI
import Network.Wai
import Network.Wai.Handler.Warp
import Soenke
import qualified Network.HTTP.Client as Http.Client
class FromText a where
fromText :: Text -> Maybe a
class ToText a where
toText :: a -> Text
instance FromText Text where
fromText = Just
instance ToText Text where
toText = id
instance FromText Bool where
fromText "true" = Just True
fromText "false" = Just False
fromText _ = Nothing
instance ToText Bool where
toText True = "true"
toText False = "false"
-- * Captures
data Capture sym a
captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type Server (Capture capture a :> sublayout) =
a -> Server sublayout
route Proxy subserver request = case pathInfo request of
(first : rest)
-> case captured captureProxy first of
Nothing -> return Nothing
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
pathInfo = rest
}
_ -> return Nothing
where captureProxy = Proxy :: Proxy (Capture capture a)
instance (KnownSymbol capture, ToText a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToPath p req
where p = unpack (toText val)
-- * Request Body support
data RQBody a
instance (FromJSON a, HasServer sublayout)
=> HasServer (RQBody a :> sublayout) where
type Server (RQBody a :> sublayout) =
a -> Server sublayout
route Proxy subserver request = do
mrqbody <- decode' <$> lazyRequestBody request
case mrqbody of
Nothing -> return Nothing
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
instance (ToJSON a, HasClient sublayout)
=> HasClient (RQBody a :> sublayout) where
type Client (RQBody a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $
setRQBody (encode body) req
-- * GET params support (i.e query string arguments)
data GetParam sym a
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (GetParam sym a :> sublayout) where
type Server (GetParam sym a :> sublayout) =
Maybe a -> Server sublayout
route Proxy subserver request = do
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramName querytext of
Nothing -> Nothing -- param absent from the query string
Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> fromText v -- if present, we try to convert to
-- the right type
route (Proxy :: Proxy sublayout) (subserver param) request
where paramName = cs $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (GetParam sym a :> sublayout) where
type Client (GetParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToQueryString pname mparamText req
where pname = pack pname'
pname' = symbolVal (Proxy :: Proxy sym)
mparamText = fmap toText mparam
-- * Example
data Greet = Greet { msg :: Text }
deriving (Generic, Show)
instance FromJSON Greet
instance ToJSON Greet
-- API specification
type TestApi =
"hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
:<|> "greet" :> RQBody Greet :> Post Greet
testApi :: Proxy TestApi
testApi = Proxy
-- Server-side handlers
server :: Server TestApi
server = hello :<|> greet
where hello name Nothing = hello name (Just False)
hello name (Just False) = return . Greet $ "Hello, " <> name
hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name
greet = return
-- Client-side query functions
clientApi :: Client TestApi
clientApi = client testApi
getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
postGreet :: Greet -> URI -> EitherT String IO Greet
getGreet :<|> postGreet = clientApi
-- Turn the server into a WAI app
test :: Application
test = serve testApi server
-- Run the server
runTestServer :: Port -> IO ()
runTestServer port = run port test
-- Run some queries against the server
runTest :: IO ()
runTest = do
tid <- forkIO $ runTestServer 8001
let Just uri = parseURI "http://localhost:8001"
print =<< runEitherT (getGreet "alp" (Just True) uri)
print =<< runEitherT (getGreet "alp" (Just False) uri)
let g = Greet "yo"
print =<< runEitherT (postGreet g uri)
killThread tid
import Servant.API
import Servant.Client
import Servant.Server
import Servant.Text

17
src/Servant/API.hs Normal file
View file

@ -0,0 +1,17 @@
module Servant.API
( module Servant.API.Capture
, module Servant.API.Get
, module Servant.API.GetParam
, module Servant.API.Post
, module Servant.API.RQBody
, module Servant.API.Sub
, module Servant.API.Union
) where
import Servant.API.Capture
import Servant.API.Get
import Servant.API.GetParam
import Servant.API.Post
import Servant.API.RQBody
import Servant.API.Sub
import Servant.API.Union

50
src/Servant/API/Capture.hs Normal file
View file

@ -0,0 +1,50 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Capture where
import Data.Proxy
import Data.Text
import GHC.TypeLits
import Network.Wai
import Servant.API.Sub
import Servant.Client
import Servant.Server
import Servant.Text
-- * Captures
data Capture sym a
captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type Server (Capture capture a :> sublayout) =
a -> Server sublayout
route Proxy subserver request = case pathInfo request of
(first : rest)
-> case captured captureProxy first of
Nothing -> return Nothing
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
pathInfo = rest
}
_ -> return Nothing
where captureProxy = Proxy :: Proxy (Capture capture a)
instance (KnownSymbol capture, ToText a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToPath p req
where p = unpack (toText val)

45
src/Servant/API/Get.hs Normal file
View file

@ -0,0 +1,45 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.API.Get where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Proxy
import Data.String.Conversions
import Network.HTTP.Types
import Network.URI
import Network.Wai
import Servant.Client
import Servant.Server
import qualified Network.HTTP.Client as Client
-- | Endpoint for simple GET requests. The server doesn't receive any arguments
-- and serves the contained type as JSON.
data Get a
instance ToJSON result => HasServer (Get result) where
type Server (Get result) = EitherT (Int, String) IO result
route Proxy action request
| null (pathInfo request) && requestMethod request == methodGet = do
e <- runEitherT action
return $ Just $ case e of
Right output ->
responseLBS ok200 [("Content-Type", "application/json")] (encode output)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| otherwise = return Nothing
instance FromJSON result => HasClient (Get result) where
type Client (Get result) = URI -> EitherT String IO result
clientWithRoute Proxy req uri = do
innerRequest <- liftIO $ reqToRequest req uri
innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
Client.httpLbs innerRequest manager
when (Client.responseStatus innerResponse /= ok200) $
left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse))
maybe (left "HTTP GET request returned invalid json") return $
decode' (Client.responseBody innerResponse)

54
src/Servant/API/GetParam.hs Normal file
View file

@ -0,0 +1,54 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.GetParam where
import Data.Proxy
import Data.String.Conversions
import Data.Text
import GHC.TypeLits
import Network.HTTP.Types
import Network.Wai
import Servant.API.Sub
import Servant.Client
import Servant.Server
import Servant.Text
-- * GET params support (i.e query string arguments)
data GetParam sym a
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (GetParam sym a :> sublayout) where
type Server (GetParam sym a :> sublayout) =
Maybe a -> Server sublayout
route Proxy subserver request = do
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramName querytext of
Nothing -> Nothing -- param absent from the query string
Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> fromText v -- if present, we try to convert to
-- the right type
route (Proxy :: Proxy sublayout) (subserver param) request
where paramName = cs $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (GetParam sym a :> sublayout) where
type Client (GetParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToQueryString pname mparamText req
where pname = pack pname'
pname' = symbolVal (Proxy :: Proxy sym)
mparamText = fmap toText mparam

51
src/Servant/API/Post.hs Normal file
View file

@ -0,0 +1,51 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.API.Post where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Proxy
import Data.String.Conversions
import Network.HTTP.Types
import Network.URI
import Network.Wai
import Servant.Client
import Servant.Server
import qualified Network.HTTP.Client as Client
-- | Endpoint for POST requests.
data Post a
instance ToJSON a => HasServer (Post a) where
type Server (Post a) = EitherT (Int, String) IO a
route Proxy action request
| null (pathInfo request) && requestMethod request == methodPost = do
e <- runEitherT action
return $ Just $ case e of
Right out ->
responseLBS status201 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| otherwise = return Nothing
instance FromJSON a => HasClient (Post a) where
type Client (Post a) = URI -> EitherT String IO a
clientWithRoute Proxy req uri = do
partialRequest <- liftIO $ reqToRequest req uri
let request = partialRequest { Client.method = methodPost
}
innerResponse <- liftIO . __withGlobalManager $ \ manager ->
Client.httpLbs request manager
when (Client.responseStatus innerResponse /= status201) $
left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))
maybe (left "HTTP POST request returned invalid json") return $
decode' (Client.responseBody innerResponse)

40
src/Servant/API/RQBody.hs Normal file
View file

@ -0,0 +1,40 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.RQBody where
import Control.Applicative
import Data.Aeson
import Data.Proxy
import Data.Text
import Network.Wai
import Servant.API.Sub
import Servant.Client
import Servant.Server
-- * Request Body support
data RQBody a
instance (FromJSON a, HasServer sublayout)
=> HasServer (RQBody a :> sublayout) where
type Server (RQBody a :> sublayout) =
a -> Server sublayout
route Proxy subserver request = do
mrqbody <- decode' <$> lazyRequestBody request
case mrqbody of
Nothing -> return Nothing
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
instance (ToJSON a, HasClient sublayout)
=> HasClient (RQBody a :> sublayout) where
type Client (RQBody a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $
setRQBody (encode body) req

39
src/Servant/API/Sub.hs Normal file
View file

@ -0,0 +1,39 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Sub where
import Data.Proxy
import Data.String.Conversions
import GHC.TypeLits
import Network.Wai
import Servant.Client
import Servant.Server
-- | The contained API (second argument) can be found under @("/" ++ path)@
-- (path being the first argument).
data (path :: k) :> a = Proxy path :> a
infixr 9 :>
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type Server (path :> sublayout) = Server sublayout
route Proxy subserver request = case pathInfo request of
(first : rest)
| first == cs (symbolVal proxyPath)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
}
_ -> return Nothing
where proxyPath = Proxy :: Proxy path
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client (path :> sublayout) = Client sublayout
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToPath p req
where p = symbolVal (Proxy :: Proxy path)

26
src/Servant/API/Union.hs Normal file
View file

@ -0,0 +1,26 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Union where
import Data.Proxy
import Servant.Client
import Servant.Server
-- | Union of two APIs, first takes precedence in case of overlap.
data a :<|> b = a :<|> b
infixr 8 :<|>
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type Server (a :<|> b) = Server a :<|> Server b
route Proxy (a :<|> b) request = do
m <- route (Proxy :: Proxy a) a request
case m of
Nothing -> route (Proxy :: Proxy b) b request
Just response -> return $ Just response
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req

66
src/Servant/Client.hs Normal file
View file

@ -0,0 +1,66 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Client where
import Control.Concurrent
import Control.Monad.Catch
import Data.ByteString.Lazy
import Data.Proxy
import Data.Text
import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Types
import Network.URI
import System.IO.Unsafe
-- * Accessing APIs as a Client
-- | 'client' allows you to produce operations to query an API from a client.
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
class HasClient layout where
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout
data Req = Req
{ reqPath :: String
, qs :: QueryText
, reqBody :: ByteString
}
defReq :: Req
defReq = Req "" [] ""
appendToPath :: String -> Req -> Req
appendToPath p req =
req { reqPath = reqPath req ++ "/" ++ p }
appendToQueryString :: Text -- ^ param name
-> Maybe Text -- ^ param value
-> Req
-> Req
appendToQueryString pname pvalue req
| pvalue == Nothing = req
| otherwise = req { qs = qs req ++ [(pname, pvalue)]
}
setRQBody :: ByteString -> Req -> Req
setRQBody b req = req { reqBody = b }
reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Request
reqToRequest req uri = fmap (setrqb . setQS ) $ parseUrl url
where url = show $ nullURI { uriPath = reqPath req }
`relativeTo` uri
setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
setQS = setQueryString $ queryTextToQuery (qs req)
{-# NOINLINE __manager #-}
__manager :: MVar Manager
__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
__withGlobalManager :: (Manager -> IO a) -> IO a
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
result <- action manager
return (manager, result)

27
src/Servant/Server.hs Normal file
View file

@ -0,0 +1,27 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server where
import Data.Proxy
import Network.HTTP.Types
import Network.Wai
-- * Implementing Servers
-- | 'serve' allows you to implement an API and produce a wai 'Application'.
serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server)
toApplication :: RoutingApplication -> Application
toApplication ra = \ request respond -> do
m <- ra request
case m of
Nothing -> respond $ responseLBS notFound404 [] "not found"
Just response -> respond response
type RoutingApplication =
Request -> IO (Maybe Response)
class HasServer layout where
type Server layout :: *
route :: Proxy layout -> Server layout -> RoutingApplication

25
src/Servant/Text.hs Normal file
View file

@ -0,0 +1,25 @@
{-# LANGUAGE OverloadedStrings #-}
module Servant.Text where
import Data.Text
class FromText a where
fromText :: Text -> Maybe a
class ToText a where
toText :: a -> Text
instance FromText Text where
fromText = Just
instance ToText Text where
toText = id
instance FromText Bool where
fromText "true" = Just True
fromText "false" = Just False
fromText _ = Nothing
instance ToText Bool where
toText True = "true"
toText False = "false"

213
src/Soenke.hs
View file

@ -1,213 +0,0 @@
{-# LANGUAGE DataKinds, FlexibleInstances, OverloadedStrings, PolyKinds,
ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module Soenke where
import Control.Concurrent
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Proxy
import Data.String.Conversions
import Data.Text (Text)
import GHC.TypeLits
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import qualified Network.HTTP.Client as Http.Client
import Network.HTTP.Types
import Network.URI
import Network.Wai
import System.IO.Unsafe (unsafePerformIO)
-- * Url Layout
-- $url_layout
-- These types allow you to specify a url layout for a REST API using a type
-- alias. The defined API doesn't really have value. It is convenient to define
-- a Proxy for every API.
--
-- The provided constructors are used in 'HasServer' and 'HasClient'.
-- | Endpoint for simple GET requests. The server doesn't receive any arguments
-- and serves the contained type as JSON.
data Get a
-- | Endpoint for POST requests.
data Post a
-- | The contained API (second argument) can be found under @("/" ++ path)@
-- (path being the first argument).
data (path :: k) :> a = Proxy path :> a
infixr 9 :>
-- | Union of two APIs, first takes precedence in case of overlap.
data a :<|> b = a :<|> b
infixr 8 :<|>
-- * Implementing Servers
-- | 'serve' allows you to implement an API and produce a wai 'Application'.
serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server)
toApplication :: RoutingApplication -> Application
toApplication ra = \ request respond -> do
m <- ra request
case m of
Nothing -> respond $ responseLBS notFound404 [] "not found"
Just response -> respond response
type RoutingApplication =
Request -> IO (Maybe Response)
class HasServer layout where
type Server layout :: *
route :: Proxy layout -> Server layout -> RoutingApplication
instance ToJSON result => HasServer (Get result) where
type Server (Get result) = EitherT (Int, String) IO result
route Proxy action request
| null (pathInfo request) && requestMethod request == methodGet = do
e <- runEitherT action
return $ Just $ case e of
Right output ->
responseLBS ok200 [("Content-Type", "application/json")] (encode output)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| otherwise = return Nothing
instance ToJSON a => HasServer (Post a) where
type Server (Post a) = EitherT (Int, String) IO a
route Proxy action request
| null (pathInfo request) && requestMethod request == methodPost = do
e <- runEitherT action
return $ Just $ case e of
Right out ->
responseLBS status201 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| otherwise = return Nothing
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type Server (path :> sublayout) = Server sublayout
route Proxy subserver request = case pathInfo request of
(first : rest)
| first == cs (symbolVal proxyPath)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
}
_ -> return Nothing
where proxyPath = Proxy :: Proxy path
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type Server (a :<|> b) = Server a :<|> Server b
route Proxy (a :<|> b) request = do
m <- route (Proxy :: Proxy a) a request
case m of
Nothing -> route (Proxy :: Proxy b) b request
Just response -> return $ Just response
-- * Accessing APIs as a Client
-- | 'client' allows you to produce operations to query an API from a client.
client :: forall layout . HasClient layout => Proxy layout -> Client layout
client Proxy = clientWithRoute (Proxy :: Proxy layout) defReq
class HasClient layout where
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout
data Req = Req
{ reqPath :: String
, qs :: QueryText
, reqBody :: ByteString
}
defReq :: Req
defReq = Req "" [] ""
appendToPath :: String -> Req -> Req
appendToPath p req =
req { reqPath = reqPath req ++ "/" ++ p }
appendToQueryString :: Text -- ^ param name
-> Maybe Text -- ^ param value
-> Req
-> Req
appendToQueryString pname pvalue req
| pvalue == Nothing = req
| otherwise = req { qs = qs req ++ [(pname, pvalue)]
}
setRQBody :: ByteString -> Req -> Req
setRQBody b req = req { reqBody = b }
reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Http.Client.Request
reqToRequest req uri = fmap (setrqb . setQS ) $ Http.Client.parseUrl url
where url = show $ nullURI { uriPath = reqPath req }
`relativeTo` uri
setrqb r = r { Http.Client.requestBody = Http.Client.RequestBodyLBS (reqBody req) }
setQS = Http.Client.setQueryString $ queryTextToQuery (qs req)
{-# NOINLINE __manager #-}
__manager :: MVar Manager
__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
__withGlobalManager :: (Manager -> IO a) -> IO a
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
result <- action manager
return (manager, result)
instance FromJSON result => HasClient (Get result) where
type Client (Get result) = URI -> EitherT String IO result
clientWithRoute Proxy req uri = do
innerRequest <- liftIO $ reqToRequest req uri
innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
Http.Client.httpLbs innerRequest manager
when (Http.Client.responseStatus innerResponse /= ok200) $
left ("HTTP GET request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
maybe (left "HTTP GET request returned invalid json") return $
decode' (Http.Client.responseBody innerResponse)
instance FromJSON a => HasClient (Post a) where
type Client (Post a) = URI -> EitherT String IO a
clientWithRoute Proxy req uri = do
partialRequest <- liftIO $ reqToRequest req uri
let request = partialRequest { Http.Client.method = methodPost
}
innerResponse <- liftIO . __withGlobalManager $ \ manager ->
Http.Client.httpLbs request manager
when (Http.Client.responseStatus innerResponse /= status201) $
left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
maybe (left "HTTP POST request returned invalid json") return $
decode' (Http.Client.responseBody innerResponse)
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client (path :> sublayout) = Client sublayout
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) $
appendToPath p req
where p = symbolVal (Proxy :: Proxy path)
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req