server-generic (empty) → 1.0.0
raw patch · 4 files changed
+712/−0 lines, 4 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, http-types, mtl, text, void, wai, warp
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- server-generic.cabal +37/−0
- src/Server/Generic.hs +643/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Gabriel Gonzalez (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Gabriel Gonzalez nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ server-generic.cabal view
@@ -0,0 +1,37 @@+name: server-generic+version: 1.0.0+synopsis: Auto-generate a server for your datatype+description: This library auto-generates a REST API from any datatype+ that derives the `Generic` interface+ .+ See the documentation in "Server.Generic" for an example of+ how to use this library+homepage: https://github.com/Gabriel439/Haskell-Server-Generic-Library+license: BSD3+license-file: LICENSE+author: Gabriel Gonzalez+maintainer: Gabriel439@gmail.com+copyright: 2016 Gabriel Gonzalez+category: Web+build-type: Simple+tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1+cabal-version: >=1.10++source-repository head+ Type: git+ Location: https://github.com/Gabriel439/Haskell-Server-Generic-Library++library+ hs-source-dirs: src+ exposed-modules: Server.Generic+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 5+ , aeson < 0.12+ , bytestring >= 0.10.0.0 && < 0.11+ , http-types >= 0.7.0 && < 0.10+ , mtl < 2.3+ , text >= 0.11.0.6 && < 1.3+ , wai >= 0.4.0 && < 3.3+ , warp < 3.3+ , void < 0.8+ ghc-options: -Wall
+ src/Server/Generic.hs view
@@ -0,0 +1,643 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++-- | This library auto-generates API services for data types using Haskell's+-- built-in support for generic programming. The best way to understand how+-- this library works is to walk through a few examples.+--+-- For example, suppose that you define the following type:+-- +-- > -- Example.hs+-- >+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > import Server.Generic+-- >+-- > data Example = Example { foo :: Int, bar :: Double }+-- > deriving (Generic)+-- >+-- > instance ParseRecord Example+-- > instance ToJSON Example+-- >+-- > handler :: Example -> IO Example+-- > handler = return+-- >+-- > main :: IO ()+-- > main = serveJSON 8080 handler+--+-- Named fields translate to query parameters which you can provide in any+-- order:+--+-- > $ stack build server-generic+-- > $ stack runghc Example.hs+-- > ...+-- > {in another terminal}+-- > $ curl 'localhost:8080/example?bar=2.5&foo=1'+-- > {"foo":1,"bar":2.5}+--+-- `serveJSON` performs the following steps:+--+-- * automatically marshals the route into the `Example` data type+-- * supplies the `Example` data type to the @handler@+-- * converts the return value of the @handler@ to JSON served back to the+-- client+--+-- Let's write a more interesting handler that creates files:+--+-- > -- Create.hs+-- > +-- > {-# LANGUAGE DeriveGeneric #-}+-- > +-- > import Server.Generic+-- > +-- > data Create = Create { filepath :: FilePath, contents :: String }+-- > deriving (Generic)+-- > +-- > instance ParseRecord Create+-- > +-- > handler :: Create -> IO ()+-- > handler create = writeFile (filepath create) (contents create)+-- > +-- > main :: IO ()+-- > main = serveJSON 8080 handler+--+-- If we run that then it will create a file any time we hit the @/create@+-- endpoint with the appropriate query parameters:+--+-- > $ curl 'localhost:8080/create?filepath=test.txt&contents=ABC'+-- > []+-- > $ cat test.txt+-- > ABC+--+-- The @[]@ in the response is just how the @aeson@ library encodes the empty+-- @()@ return value of the handler.+--+-- Unlabeled fields translate to path tokens in the route. For example, this+-- type:+--+-- > -- Example.hs+-- > +-- > {-# LANGUAGE DeriveGeneric #-}+-- > +-- > import Server.Generic+-- > +-- > data Example = Example Int Double Text+-- > deriving (Generic)+-- > +-- > instance ParseRecord Example+-- > instance ToJSON Example+-- > +-- > handler :: Example -> IO Example+-- > handler = return+-- > +-- > main :: IO ()+-- > main = serveJSON 8080 handler+--+-- ... translates to a @\/example\/:int\/:double\/:text@ route that captures the+-- last three tokens as the fields of the @Example@ type:+--+-- > $ curl 'localhost:8080/example/1/2.5/foo'+-- > [1,2.5,"foo"]+--+-- Also, unlabeled data types get converted to an array when rendered as JSON.+--+-- Certain types of fields are given special treatment, such as in this example:+--+-- > data Example = Example+-- > { list :: [Int]+-- > , optional :: Maybe Int+-- > , first :: First Int+-- > , last :: Last Int+-- > } deriving (Generic)+--+-- This gives the following behavior:+--+-- > $ curl 'localhost:8080/example?optional=1&list=1&list=2&first=1&first=2&last=1&last=2'+-- > {"list":[1,2],"first":1,"last":2,"optional":1}+-- > +-- > $ curl 'localhost:8080/example'+-- > {"list":[],"first":null,"last":null,"optional":null}+--+-- If a datatype has multiple constructors:+--+-- > data Example+-- > = Create { name :: Text, duration :: Maybe Int }+-- > | Kill { name :: Text }+-- > deriving (Generic)+--+-- ... then they will translate into multiple API endpoints:+--+-- +-- > $ curl 'localhost:8080/create?name=foo&duration=60'+-- > {"tag":"Create","name":"foo","duration":60}+-- > $ curl 'localhost:8080/kill?name=foo'+-- > {"tag":"Kill","name":"foo"}+--+-- This library also provides out-of-the-box support for many existing types,+-- like tuples and `Either`:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- > +-- > import Server.Generic+-- > +-- > handler :: Either Int Double -> IO (Either Int Double)+-- > handler = return+-- > +-- > main :: IO ()+-- > main = serveJSON 8080 handler+--+-- > $ curl 'localhost:8080/left/1'+-- > {"Left":1}+-- > $ curl 'localhost:8080/right/2.5'+-- > {"Right":2.5}+--+-- > handler :: (Int, Double) -> IO (Int, Double)+-- > handler = return+--+-- > $ curl 'localhost:8080/1/2.5'+-- > [1,2.5]+--+-- ... and you can also just parse a single value:+--+-- > handler :: Int -> IO Int+-- > handler = return+--+-- > $ curl 'localhost:8080/1'+-- > 1+--+-- However, there are some types that this library cannot generate sensible+-- routes for, such as:+--+-- * recursive types:+--+-- > data Example = Example { foo :: Example }+--+-- * records whose fields are other records+--+-- > data Outer = Outer { foo :: Inner } deriving (Show, Generic)+-- > data Inner = Inner { bar :: Int } deriving (Show, Generic)+--+-- * record fields with nested `Maybe`s or nested lists+--+-- > data Example = Example { foo :: Maybe (Maybe Int) }+-- > data Example = Example { foo :: [[Int]] }+--+-- If you try to auto-generate a parser for these types you will get an error at+-- compile time that will look something like this:+--+-- > No instance for (ParseFields TheTypeOfYourField)+-- > arising from a use of ‘Server.Generic.$gdmparseRecord’+-- > In the expression: Server.Generic.$gdmparseRecord+-- > In an equation for ‘parseRecord’:+-- > parseRecord = Server.Generic.$gdmparseRecord+-- > In the instance declaration for ‘ParseRecord TheTypeOfYourRecord’++module Server.Generic (+ -- * Server+ serve+ , serveJSON+ , serveOK++ -- * Parser+ , Route(..)+ , Parser(..)+ , ParseRecord(..)+ , ParseFields(..)+ , ParseField(..)+ , Only(..)+ , getOnly++ -- * Re-exports+ , Generic+ , ToJSON+ , Data.Text.Text+ , All(..)+ , Any(..)+ , First(..)+ , Last(..)+ , Sum(..)+ , Product(..)+ ) where++import Control.Applicative+import Control.Monad (guard, MonadPlus)+import Control.Monad.State (MonadState(..), StateT)+import Data.Aeson (ToJSON)+import Data.Monoid+import Data.Void (Void)+import GHC.Generics+import Network.Wai (Response)+import Network.Wai.Handler.Warp (Port)++import qualified Control.Monad.State+import qualified Data.Aeson+import qualified Data.ByteString+import qualified Data.ByteString.Lazy+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy+import qualified Network.HTTP.Types.Status+import qualified Network.HTTP.Types.URI+import qualified Network.Wai.Handler.Warp+import qualified Network.Wai+import qualified Text.Read++-- | A list of path tokens which were originally separated by @'/'@s+data Route = Route+ { path :: [Data.Text.Text]+ , query :: [(Data.ByteString.ByteString, Data.ByteString.ByteString)]+ } deriving (Show)++-- | A backtracking `Route` parser+newtype Parser a = Parser { unParser :: StateT Route [] a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , Alternative+ , MonadPlus+ , MonadState Route+ )++{-| A class for types that can be parsed from path tokens or query parameters++ This class has a default implementation for any type that implements+ `Generic` and you can derive `Generic` for many types by enabling the+ @DeriveGeneric@ language extension++ You can also use `getOnly` to create a `ParseRecord` instance from a+ `ParseFields` instance:++> instance ParseRecord MyType where+> parseRecord = fmap getOnly parseRecord+-}+class ParseRecord a where+ parseRecord :: Parser a+ default parseRecord :: (Generic a, GenericParseRecord (Rep a)) => Parser a+ parseRecord = fmap to genericParseRecord++instance ParseFields a => ParseRecord (Only a) where+ parseRecord = fmap Only (parseFields Nothing)++instance ParseRecord Char where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Double where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Float where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Int where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Integer where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord () where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Any where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord All where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Data.ByteString.ByteString where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Data.ByteString.Lazy.ByteString where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Data.Text.Text where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Data.Text.Lazy.Text where+ parseRecord = fmap getOnly parseRecord+instance ParseField a => ParseRecord (Maybe a) where+ parseRecord = fmap getOnly parseRecord+instance ParseField a => ParseRecord (First a) where+ parseRecord = fmap getOnly parseRecord+instance ParseField a => ParseRecord (Last a) where+ parseRecord = fmap getOnly parseRecord+instance (Num a, ParseField a) => ParseRecord (Sum a) where+ parseRecord = fmap getOnly parseRecord+instance (Num a, ParseField a) => ParseRecord (Product a) where+ parseRecord = fmap getOnly parseRecord+instance ParseField a => ParseRecord [a] where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Bool where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Ordering where+ parseRecord = fmap getOnly parseRecord+instance ParseRecord Void where+ parseRecord = fmap getOnly parseRecord++instance (ParseFields a, ParseFields b) => ParseRecord (a, b) where+ parseRecord =+ (,)+ <$> parseFields Nothing+ <*> parseFields Nothing++instance (ParseFields a, ParseFields b, ParseFields c) => ParseRecord (a, b, c) where+ parseRecord =+ (,,)+ <$> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing++instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d) => ParseRecord (a, b, c, d) where+ parseRecord =+ (,,,)+ <$> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing++instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d, ParseFields e) => ParseRecord (a, b, c, d, e) where+ parseRecord =+ (,,,,)+ <$> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing++instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d, ParseFields e, ParseFields f) => ParseRecord (a, b, c, d, e, f) where+ parseRecord =+ (,,,,,)+ <$> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing++instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d, ParseFields e, ParseFields f, ParseFields g) => ParseRecord (a, b, c, d, e, f, g) where+ parseRecord =+ (,,,,,,)+ <$> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing+ <*> parseFields Nothing++instance (ParseFields a, ParseFields b) => ParseRecord (Either a b)++{-| A 1-tuple, used solely to translate `ParseFields` instances into+ `ParseRecord` instances+-}+newtype Only a = Only a deriving (Generic, Show)++{-| This is a convenience function that you can use if you want to create a+ `ParseRecord` instance that just defers to the `ParseFields` instance for+ the same type:++> instance ParseRecord MyType where+> parseRecord = fmap getOnly parseRecord+-}+getOnly :: Only a -> a+getOnly (Only x) = x++class GenericParseRecord f where+ genericParseRecord :: Parser (f a)++instance GenericParseRecord U1 where+ genericParseRecord = pure U1++instance GenericParseRecord V1 where+ genericParseRecord = empty++instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :+: g) where+ genericParseRecord =+ fmap L1 genericParseRecord <|> fmap R1 genericParseRecord++instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :*: g) where+ genericParseRecord = liftA2 (:*:) genericParseRecord genericParseRecord++instance (Constructor c, GenericParseRecord f) => GenericParseRecord (M1 C c f) where+ genericParseRecord = do+ let m :: M1 i c f a+ m = undefined++ text <- parseField Nothing+ guard (text == Data.Text.toLower (Data.Text.pack (conName m)))+ fmap M1 genericParseRecord++instance (GenericParseRecord f) => GenericParseRecord (M1 D c f) where+ genericParseRecord = fmap M1 genericParseRecord++instance (Selector s, ParseFields a) => GenericParseRecord (M1 S s (K1 i a)) where+ genericParseRecord = do+ let m :: M1 i s f a+ m = undefined++ let label = case selName m of+ "" -> Nothing+ name -> Just (Data.Text.pack name)+ fmap (M1 . K1) (parseFields label)++{-| A class for all types that can be parsed from zero or more path tokens or+ query parameters++ `parseFields` has a default implementation for any type that implements+ `ParseField`+-}+class ParseRecord a => ParseFields a where+ parseFields+ :: Maybe Data.Text.Text+ -- ^ Field label (`Nothing` for path token, and `Just` for query param)+ -> Parser a+ default parseFields :: ParseField a => Maybe Data.Text.Text -> Parser a+ parseFields = parseField++instance ParseFields Char+instance ParseFields Double+instance ParseFields Float+instance ParseFields Int+instance ParseFields Integer+instance ParseFields Ordering+instance ParseFields Void+instance ParseFields Data.ByteString.ByteString+instance ParseFields Data.ByteString.Lazy.ByteString+instance ParseFields Data.Text.Text+instance ParseFields Data.Text.Lazy.Text+instance ParseFields Bool+instance ParseFields ()++instance ParseFields Any where+ parseFields m = (fmap mconcat . many . fmap Any) (parseField m)++instance ParseFields All where+ parseFields m = (fmap mconcat . many . fmap All) (parseField m)++instance ParseField a => ParseFields (Maybe a) where+ parseFields m = optional (parseField m)++instance ParseField a => ParseFields (First a) where+ parseFields m = (fmap mconcat . many . fmap (First . Just)) (parseField m)++instance ParseField a => ParseFields (Last a) where+ parseFields m = (fmap mconcat . many . fmap (Last . Just)) (parseField m)++instance (Num a, ParseField a) => ParseFields (Sum a) where+ parseFields m = (fmap mconcat . many . fmap Sum) (parseField m)++instance (Num a, ParseField a) => ParseFields (Product a) where+ parseFields m = (fmap mconcat . many . fmap Product) (parseField m)++instance ParseField a => ParseFields [a] where+ parseFields = parseListOfField++{-| A class for all record fields that can be parsed from exactly one+ path token or query parameter++ `parseField` has a default implementation for any type that implements+ `Read`+-}+class ParseField a where+ parseField+ :: Maybe Data.Text.Text+ -- ^ Field label (`Nothing` for path token, and `Just` for query param)+ -> Parser a+ default parseField :: Read a => Maybe Data.Text.Text -> Parser a+ parseField m = do+ text <- parseField m+ case Text.Read.readMaybe (Data.Text.unpack text) of+ Nothing -> empty+ Just a -> return a++ parseListOfField+ :: Maybe Data.Text.Text+ -- ^ Field label+ -> Parser [a]+ parseListOfField m = many (parseField m)++instance ParseField Data.ByteString.ByteString where+ parseField Nothing =+ fmap Data.Text.Encoding.encodeUtf8 (parseField Nothing)+ parseField (Just label) = do+ let labelBytes = Data.Text.Encoding.encodeUtf8 label++ let pop [] = empty+ pop ((k, v):kvs)+ | k == labelBytes = return (v, kvs)+ | otherwise = do+ (v', kvs') <- pop kvs+ return (v', (k, v):kvs')++ Route tokens params <- get+ case pop params of+ Just (v, params') -> do+ put (Route tokens params')+ return v+ Nothing -> empty++instance ParseField Data.Text.Text where+ parseField Nothing = do+ Route tokens params <- get+ case tokens of+ [] -> empty+ token:tokens' -> do+ put (Route tokens' params)+ return token+ parseField (Just label) = do+ bytes <- parseField (Just label)+ case Data.Text.Encoding.decodeUtf8' bytes of+ Left _ -> empty+ Right text -> return text++instance ParseField Data.Text.Lazy.Text where+ parseField m = fmap Data.Text.Lazy.fromStrict (parseField m)++instance ParseField Data.ByteString.Lazy.ByteString where+ parseField m = fmap Data.ByteString.Lazy.fromStrict (parseField m)++instance ParseField Bool+instance ParseField Double+instance ParseField Float+instance ParseField Int+instance ParseField Integer+instance ParseField Ordering+instance ParseField Void++instance ParseField String where+ parseField m = fmap Data.Text.unpack (parseField m)++instance ParseField Char where+ parseField m = do+ string <- parseField m+ case string of+ [c] -> return c+ _ -> empty++ parseListOfField m = parseField m++instance ParseField () where+ parseField _ = pure ()++instance ParseField All where+ parseField m = fmap All (parseField m)++instance ParseField Any where+ parseField m = fmap Any (parseField m)++{-| Simple server that listens on the given `Port` and runs the handler for+ each incoming connection++ The value supplied to the handler is automatically parsed from the route++ The request method is ignored++ Failure to parse a value from the route results in a response with a 404+ status code+-}+serve+ :: ParseRecord a+ => Port+ -- ^ Port to listen on+ -> (a -> IO Response)+ -- ^ Handler for parsed value+ -> IO ()+ -- ^ Run the server+serve port handler = Network.Wai.Handler.Warp.run port application+ where+ application request respond = do+ let rawQuery = Network.Wai.rawQueryString request+ let route = Route+ { path = Network.Wai.pathInfo request+ , query = Network.HTTP.Types.URI.parseSimpleQuery rawQuery+ }++ let parser = do+ x <- parseRecord+ Route tokens params <- get+ guard (null tokens && null params)+ return x++ case Control.Monad.State.evalStateT (unParser parser) route of+ [] -> do+ let status = Network.HTTP.Types.Status.status404+ let response =+ Network.Wai.responseLBS status [] "404 Not Found\n"+ respond response+ a:_ -> do+ response <- handler a+ respond response++{-| Like `serve` except the handler result is automatically encoded as JSON and+ served as the `Response`+-}+serveJSON :: (ParseRecord a, ToJSON b) => Port -> (a -> IO b) -> IO ()+serveJSON port handler = serve port handler'+ where+ handler' a = do+ b <- handler a+ let status = Network.HTTP.Types.Status.status200+ return (Network.Wai.responseLBS status [] (Data.Aeson.encode b <> "\n"))++-- | Like `serve` except the `Response` is always @\"200 OK\"@+serveOK :: ParseRecord a => Port -> (a -> IO ()) -> IO ()+serveOK port handler = serve port handler'+ where+ handler' a = do+ handler a+ let status = Network.HTTP.Types.Status.status200+ return (Network.Wai.responseLBS status [] "200 OK\n")