git.iko.soy/servant
on master help sign in
beginning of a new implementation, using Soenke's typed rest
c35a510Alp Mestanogullari
LICENSEnew file+30
compare with master
unifiedsplit
@@ -0,0 +1,30 @@
1+Copyright (c) 2014, Alp Mestanogullari
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Alp Mestanogullari nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant.cabalnew file+33
@@ -0,0 +1,33 @@
1+name: servant
2+version: 0.2
3+-- synopsis:
4+-- description:
5+license: BSD3
6+license-file: LICENSE
7+author: Alp Mestanogullari
8+maintainer: alpmestan@gmail.com
9+-- copyright:
10+category: Web
11+build-type: Simple
12+-- extra-source-files:
13+cabal-version: >=1.10
14+
15+library
16+ exposed-modules: Servant Soenke
17+ -- other-modules:
18+ -- other-extensions:
19+ build-depends:
20+ base >=4 && <5
21+ , either
22+ , aeson
23+ , string-conversions
24+ , http-client
25+ , http-types
26+ , network-uri
27+ , wai
28+ , warp
29+ , transformers
30+ , text
31+ hs-source-dirs: src
32+ default-language: Haskell2010
33+ ghc-options: -O2
src/Servant.hsnew file+75
@@ -0,0 +1,75 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+module Servant where
10+
11+import Data.Aeson
12+import Data.Monoid
13+import Data.Proxy
14+import Data.Text
15+import GHC.Generics
16+import GHC.TypeLits
17+import Network.Wai
18+import Network.Wai.Handler.Warp
19+import Soenke
20+
21+data Capture sym a
22+
23+class Captured a where
24+ capture :: Text -> Maybe a
25+
26+instance Captured Text where
27+ capture = Just
28+
29+captured :: Captured a => proxy (Capture sym a) -> Text -> Maybe a
30+captured _ = capture
31+
32+instance (KnownSymbol capture, Captured a, HasServer sublayout)
33+ => HasServer (Capture capture a :> sublayout) where
34+
35+ type Server (Capture capture a :> sublayout) =
36+ Capture capture a :> (a -> Server sublayout)
37+
38+ route Proxy (capture :> subserver) request = case pathInfo request of
39+ (first : rest)
40+ -> case captured capture first of
41+ Nothing -> return Nothing
42+ Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
43+ pathInfo = rest
44+ }
45+ _ -> return Nothing
46+
47+type TestApi = "hello" :> Capture "name" Text :> Get Greet
48+
49+testApi :: Proxy TestApi
50+testApi = Proxy
51+
52+data Greet = Greet { msg :: Text }
53+ deriving Generic
54+
55+instance ToJSON Greet
56+
57+server :: Server TestApi
58+server =
59+ (Proxy :: Proxy "hello")
60+ :> (Proxy :: Proxy (Capture "name" Text))
61+ :> (return . func)
62+
63+ where func name = Greet ("Hello, " <> name)
64+
65+test :: Application
66+test = serve testApi server
67+
68+runTest :: Port -> IO ()
69+runTest port = run port test
70+
71+-- load in ghci, call 'runTest 8000'
72+-- visit http://localhost/hello/world
73+-- visit http://localhost/hello/soenke
74+-- visit http://localhost/hello/alp
75+
src/Soenke.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE DataKinds, FlexibleInstances, OverloadedStrings, PolyKinds,
2+ ScopedTypeVariables, TypeFamilies, TypeOperators #-}
3+module Soenke where
4+
5+import Control.Concurrent
6+import Control.Monad
7+import Control.Monad.IO.Class
8+import Control.Monad.Trans.Either
9+import Data.Aeson
10+import Data.Proxy
11+import Data.String.Conversions
12+import GHC.TypeLits
13+import Network.HTTP.Client (Manager, defaultManagerSettings,
14+ newManager)
15+import qualified Network.HTTP.Client as Http.Client
16+import Network.HTTP.Types
17+import Network.URI
18+import Network.Wai
19+import System.IO.Unsafe (unsafePerformIO)
20+
21+
22+-- * Url Layout
23+
24+-- $url_layout
25+-- These types allow you to specify a url layout for a REST API using a type
26+-- alias. The defined API doesn't really have value. It is convenient to define
27+-- a Proxy for every API.
28+--
29+-- The provided constructors are used in 'HasServer' and 'HasClient'.
30+
31+-- | Endpoint for simple GET requests. The server doesn't receive any arguments
32+-- and serves the contained type as JSON.
33+data Get a
34+
35+-- | The contained API (second argument) can be found under @("/" ++ path)@
36+-- (path being the first argument).
37+data (path :: k) :> a = Proxy path :> a
38+infixr 9 :>
39+
40+-- | Union of two APIs, first takes precedence in case of overlap.
41+data a :<|> b = a :<|> b
42+infixr 8 :<|>
43+
44+
45+-- * Implementing Servers
46+
47+-- | 'serve' allows you to implement an API and produce a wai 'Application'.
48+serve :: HasServer layout => Proxy layout -> Server layout -> Application
49+serve p server = toApplication (route p server)
50+
51+toApplication :: RoutingApplication -> Application
52+toApplication ra = \ request respond -> do
53+ m <- ra request
54+ case m of
55+ Nothing -> respond $ responseLBS notFound404 [] "not found"
56+ Just response -> respond response
57+
58+type RoutingApplication =
59+ Request -> IO (Maybe Response)
60+
61+class HasServer layout where
62+ type Server layout :: *
63+ route :: Proxy layout -> Server layout -> RoutingApplication
64+
65+instance ToJSON result => HasServer (Get result) where
66+ type Server (Get result) = (EitherT (Int, String) IO result)
67+ route Proxy action _request = do
68+ e <- runEitherT action
69+ return $ Just $ case e of
70+ Right output ->
71+ responseLBS ok200 [("Content-Type", "application/json")] (encode output)
72+ Left (status, message) ->
73+ responseLBS (mkStatus status (cs message)) [] (cs message)
74+
75+instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
76+ type Server (path :> sublayout) = path :> (Server sublayout)
77+ route Proxy (path :> subserver) request = case pathInfo request of
78+ (first : rest)
79+ | first == cs (symbolVal path)
80+ -> route (Proxy :: Proxy sublayout) subserver request{
81+ pathInfo = rest
82+ }
83+ _ -> return Nothing
84+
85+instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
86+ type Server (a :<|> b) = (Server a :<|> Server b)
87+ route Proxy (a :<|> b) request = do
88+ m <- route (Proxy :: Proxy a) a request
89+ case m of
90+ Nothing -> route (Proxy :: Proxy b) b request
91+ Just response -> return $ Just response
92+
93+
94+-- * Accessing APIs as a Client
95+
96+-- | 'client' allows you to produce operations to query an API from a client.
97+client :: forall layout . HasClient layout => Proxy layout -> Client layout
98+client Proxy = clientWithRoute (Proxy :: Proxy layout) ""
99+
100+class HasClient layout where
101+ type Client layout :: *
102+ clientWithRoute :: Proxy layout -> String -> Client layout
103+
104+{-# NOINLINE __manager #-}
105+__manager :: MVar Manager
106+__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
107+
108+__withGlobalManager :: (Manager -> IO a) -> IO a
109+__withGlobalManager action = modifyMVar __manager $ \ manager -> do
110+ result <- action manager
111+ return (manager, result)
112+
113+instance FromJSON result => HasClient (Get result) where
114+ type Client (Get result) = URI -> EitherT String IO result
115+ clientWithRoute Proxy path uri = do
116+ innerRequest <- liftIO $
117+ Http.Client.parseUrl (show (nullURI{uriPath = path} `relativeTo` uri))
118+ innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
119+ Http.Client.httpLbs innerRequest manager
120+ when (Http.Client.responseStatus innerResponse /= ok200) $
121+ left ("kraken daemon returned: " ++ show (Http.Client.responseStatus innerResponse))
122+ maybe (left "kraken daemon returned invalid json") return $
123+ decode' (Http.Client.responseBody innerResponse)
124+
125+instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
126+ type Client (path :> sublayout) = path :> (Client sublayout)
127+ clientWithRoute Proxy path =
128+ (Proxy :: Proxy path) :>
129+ clientWithRoute (Proxy :: Proxy sublayout)
130+ (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
131+
132+instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
133+ type Client (a :<|> b) = (Client a :<|> Client b)
134+ clientWithRoute Proxy path =
135+ clientWithRoute (Proxy :: Proxy a) path :<|>
136+ clientWithRoute (Proxy :: Proxy b) path