git.iko.soy/servant
on 14e6a49 help sign in
servant/src/Servant/API/Get.hs
57 lines 2.1 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Servant.API.Get where
6import Control.Monad
7import Control.Monad.IO.Class
8import Control.Monad.Trans.Either
9import Data.Aeson
10import Data.Proxy
11import Data.String.Conversions
12import Network.HTTP.Types
13import Network.URI
14import Network.Wai
15import Servant.Client
16import Servant.Docs
17import Servant.Server
19import qualified Network.HTTP.Client as Client
21-- | Endpoint for simple GET requests. The server doesn't receive any arguments
22-- and serves the contained type as JSON.
23data Get a
25instance ToJSON result => HasServer (Get result) where
26 type Server (Get result) = EitherT (Int, String) IO result
27 route Proxy action request respond
28 | null (pathInfo request) && requestMethod request == methodGet = do
29 e <- runEitherT action
30 respond . succeedWith $ case e of
31 Right output ->
32 responseLBS ok200 [("Content-Type", "application/json")] (encode output)
33 Left (status, message) ->
34 responseLBS (mkStatus status (cs message)) [] (cs message)
35 | null (pathInfo request) && requestMethod request /= methodGet =
36 respond $ failWith WrongMethod
37 | otherwise = respond $ failWith NotFound
39instance FromJSON result => HasClient (Get result) where
40 type Client (Get result) = URIAuth -> EitherT String IO result
41 clientWithRoute Proxy req host = do
42 innerRequest <- liftIO $ reqToRequest req host
44 innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
45 Client.httpLbs innerRequest manager
46 when (Client.responseStatus innerResponse /= ok200) $
47 left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse))
48 maybe (left "HTTP GET request returned invalid json") return $
49 decode' (Client.responseBody innerResponse)
51instance ToSample a => HasDocs (Get a) where
52 docsFor Proxy (endpoint, action) =
53 single endpoint' action'
55 where endpoint' = endpoint & method .~ DocGET
56 action' = action & response.respBody .~ toSample p
57 p = Proxy :: Proxy a