@@ -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