reorganize everything into a sane(r) module structure

example/greet.hs

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

servant.cabal

@@ -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:
@@ -32,4 +44,19 @@ library
     , text
   hs-source-dirs: src
   default-language: Haskell2010
-  ghc-options: -O2
+  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

src/Servant.hs

@@ -1,202 +1,11 @@
-{-# LANGUAGE DataKinds #-}
+module Servant
-{-# LANGUAGE PolyKinds #-}
+  ( module Servant.API
-{-# LANGUAGE TypeFamilies #-}
+  , module Servant.Client
-{-# LANGUAGE DeriveGeneric #-}
+  , module Servant.Server
-{-# LANGUAGE TypeOperators #-}
+  , module Servant.Text
-{-# LANGUAGE FlexibleContexts #-}
+  ) where
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Servant where
 
-import Control.Applicative
+import Servant.API
-import Control.Concurrent (forkIO, killThread)
+import Servant.Client
-import Control.Monad
+import Servant.Server
-import Control.Monad.IO.Class
+import Servant.Text
-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

src/Servant/API.hs

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

src/Servant/API/Capture.hs

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

src/Servant/API/Get.hs

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

src/Servant/API/GetParam.hs

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

src/Servant/API/Post.hs

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

src/Servant/API/RQBody.hs

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

src/Servant/API/Sub.hs

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

src/Servant/API/Union.hs

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

src/Servant/Client.hs

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

src/Servant/Server.hs

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

src/Servant/Text.hs

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

src/Soenke.hs

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